Cache for Windows NT^INT^797 FILEMAN ROUTINES FROM GFT -- VERSION 1036, RUN ^DINIT^~Format=Cache.S~ %RO on 23 Sep 2009 6:56 AM DDBR^INT^1^60300,29508^0 DDBR ;SFISC/DCL-VA FILEMAN BROWSER ;03:23 PM 22 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 EN N DDBC,DDBFLG,DDBL,DDBPMSG,DDBSA,DDBX,IOTM,IOBM I '$$TEST^DDBRT W $C(7),!!,$$EZBLD^DIALOG(830),!! Q ;** D LIST^DDBR3(.DDBX) I DDBX'>0 W:DDBX=0 $C(7),!!,$$EZBLD^DIALOG(1404),!! Q ;** S DDBSA=DDBX(6) S DDBFLG=DDBX(4) S DDBPMSG=DDBX(5) D CONTNU D KTMP^DDBRU Q WP(DDBFN,DDBRN,DDBFLD,DDBFLG,DDBPMSG,DDBL,DDBC,IOTM,IOBM) N DDBSA S DDBSA=$$GET^DIQG($G(DDBFN),$G(DDBRN),$G(DDBFLD),"B") I $G(DIERR) D CLEAN Q S DDBSA=$P(DDBSA,"$CREF$",2) I DDBSA']"" D ERR("FILE, RECORD and/or FIELD") Q I '$D(@DDBSA) D ERR("SOURCE ARRAY") Q I $G(DDBFLG)["A" D .N DDBSAN .S DDBSAN=$$NROOT^DDBRAP($NA(@DDBSA)) .I '$D(@DDBSAN) D WP^DDBRAP($NA(@DDBSA)) .Q:$G(DDBPMSG)]"" .I $D(@DDBSAN@("TITLE")) S DDBPMSG=@DDBSAN@("TITLE") Q .Q S DDBPMSG=$S($G(DDBPMSG)]"":DDBPMSG,1:"VA FileMan Browser (wp) DOCUMENT 1") D CONTNU D:$G(DDBFLG)'["P" KTMP^DDBRU Q BROWSE(DDBSA,DDBFLG,DDBPMSG,DDBL,DDBC,IOTM,IOBM) N DDBRLIST CONTNU I $G(U)'="^" N U S U="^" I $G(DDBFLG)["A" D .N DDBSAN .S DDBSAN=$$NROOT^DDBRAP($NA(@DDBSA)) .I '$D(@DDBSAN) D WP^DDBRAP($NA(@DDBSA)) .Q:$G(DDBPMSG)]"" .I $D(@DDBSAN@("TITLE")) S DDBPMSG=@DDBSAN@("TITLE") Q .Q S DDBPMSG=$S($G(DDBPMSG)]"":DDBPMSG,1:"VA FileMan Browser DOCUMENT 1") N %,D,DX,IOP,XY,X,Y D:$G(DDBFLG)'["H" INIT I $G(DIERR) D CLEAN Q I $G(DDBSA)']"" D ERR("SOURCE ARRAY") Q I '$D(@DDBSA) D ERR("SOURCE ARRAY") Q I $G(DDBFLG)'["N",DDBSA'="^TMP(""DDB"",$J)" D .I $NA(@DDBSA)=$NA(^TMP("DDB",$J)) S DDBSA="^TMP(""DDB"",$J)" Q .K ^TMP("DDB",$J) .D XY^%RCR($$OREF(DDBSA),"^TMP(""DDB"",$J,") .;M ^TMP("DDB",$J)=@DDBSA .S DDBSA="^TMP(""DDB"",$J)" .Q N DDBRE,DDBRPE,DDBPSA,DDBTO,DDBDM,DDBFNO,I,DDBFLGS,DDBRHT,DDBRHTF N DDBHDR,DDBHDRC,DDBFTR,DDBSP,DDBSF,DDBST,DDBTL,DDBTPG,DDBZN I '$G(DDBRLIST) N DDBSRL,DDBSX,DDBSY,DDBRSA S DDBFTR=$E("Col> |"_$$EZBLD^DIALOG(8074)_"| Line> Screen>"_$J("",IOM),1,IOM) ;** I '$G(DDBRLIST) S IOBM=$S($G(IOBM)>0:IOBM,1:$G(IOSL,24))-1,IOTM=$S($G(IOTM)>0:IOTM,1:1)+1 S DDBRSA=0 D TB^DDBRS(.IOTM,.IOBM,.DDBRSA) S DDBSX="0;4;40;65" S DDBSY=DDBRSA(0,"DDBSY") I IOBM>(IOSL-1) D ERR($$EZBLD^DIALOG(833)) Q ;** I IOTM<2 D ERR($$EZBLD^DIALOG(832)) Q ;** I IOBM'>IOTM D ERR($$EZBLD^DIALOG(831)) Q ;** S DDBSRL=DDBRSA(0,"DDBSRL") I DDBSRL'>4,$G(DDBFLG)'["H" D ERR($$EZBLD^DIALOG(834)) Q ;** I DDBRSA(1,"DDBSRL")'>4 K DDBRSA(1),DDBRSA(2) S DDBHDR=$$CTXT(DDBPMSG,$J("",IOM+1),IOM),DDBHDRC=0 S DDBTL=$P($G(@DDBSA@(0)),"^",3) S:DDBTL'>0 DDBTL=$O(@DDBSA@(" "),-1) I DDBTL'>0 D I DDBTL'>0 D BLD^DIALOG(1700,$$EZBLD^DIALOG(1404)_DDBSA) D CLEAN Q ;** .N I S I=0 F S I=$O(@DDBSA@(I)) Q:I'>0 S DDBTL=I .Q S DDBZN=$D(@DDBSA@(DDBTL,0))#2,DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1),DDBSF=1,DDBST=IOM S DDBDM=DDBSA="^TMP(""DDB"",$J)" I $G(DDBC)=+$G(DDBC) D ERR("TAB (Closed Array Root)") Q S:$G(DDBC)="" DDBC="^TMP(""DDBC"",$J)" I '$D(@DDBC) F I=1,22:22:176 S @DDBC@(I)="" I $D(@DDBC@(1))'>9 N DDBC0,DDBC1 S @DDBC@(1)="",DDBC1=1,DDBC0=DDBC S DDBPSA=0,DDBFLG=$G(DDBFLG) S DDBFLGS=DDBFLG["S",DDBRHTF=DDBFLG["A" I DDBRHTF S $E(DDBFTR,1,9)="HYPER-TXT" G EN^DDBRGE DOCLIST(DDBDSA,DDBFLG,IOTM,IOBM) S IOP="HOME" D ^%ZIS N DDBPMSG,DDBL,DDBC,DDBSA,DDBSRL,DDBSX,DDBSY,DDBRSA,DDBRLIST S IOBM=$S($G(IOBM)>0:IOBM,1:$G(IOSL,24))-1,IOTM=$S($G(IOTM)>0:IOTM,1:1)+1 S DDBSX="0;4;40;65" S DDBSY=(IOTM-2)_";"_(IOTM-1)_";"_(IOBM-1)_";"_(IOBM) ;hdr,txttop,txtbot,ftr I IOBM>(IOSL-1) D ERR($$EZBLD^DIALOG(833)) Q ;** I IOTM<2 D ERR($$EZBLD^DIALOG(832)) Q ;** I IOBM'>IOTM D ERR($$EZBLD^DIALOG(831)) Q ;** S DDBSRL=(IOBM-IOTM)+1 ;scroll region lines I '$D(@DDBDSA) D ERR("DOCUMENT ARRAY INVALID") Q S DDBFLG=$TR($G(DDBFLG),"P")_"N" S DDBPMSG=$O(@DDBDSA@("")) S:DDBPMSG]"" DDBSA=@DDBDSA@(DDBPMSG) I DDBPMSG']""!(DDBSA']"") D ERR("DOCUMENT ARRAY INVALID") Q D I $G(DIERR) K ^TMP("DDBLST",$J) D CLEAN Q .N DOC,DOCSA .S DOC="" .K ^TMP("DDBLST",$J) .F S DOC=$O(@DDBDSA@(DOC)) Q:DOC="" D ..S DOCSA=@DDBDSA@(DOC) ..D LOADCL^DDBR4(DOCSA,"",DOC) ..Q .Q Q:$G(DDBENDR) S DDBRLIST=1 G CONTNU RTN G DR^DDBRU ROOT G EN^DDBRU2 CTXT(X,T,W) Q:X="" $G(T) N HW S W=$G(W,79),HW=W\2 S $E(T,HW-($L(X)\2),HW-($L(X)\2)+$L(X))=X Q $E(T,1,W) OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_"," OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 % S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q % INIT I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU D INIT^DDGLIB0() I $G(DIERR) Q I '$D(IOSTBM)!('$D(IOIL)) S X="IOSTBM;IORI" D ENDR^%ZISS D:$G(IOSTBM)="" TRMERR^DDGLIB0($$EZBLD^DIALOG(831)) ;** D:$G(IORI)="" TRMERR^DDGLIB0($$EZBLD^DIALOG(835)) Q ERR(DDBERR) N P S P(1)=DDBERR I $G(U)="^" N U S U="^" D BLD^DIALOG(202,.P),OUT^DDBRU:$D(DDGLDEL) CLEAN D:'$D(DDS) KILL^DDGLIB0($G(DDBFLG)) Q DDBR0^INT^1^60300,29508^0 DDBR0 ;SFISC/DCL-VA FILEMAN BROWSER FUNCTIONS ;04:01 PM 26 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 Q PU N I,J,K S I=DDBL-DDBSRL,J=I-(DDBSRL-1),K=DDBL S DX=$P(DDBSX,";"),DY=$P(DDBSY,";",2) I DDBZN D D:K'=DDBL RLPI Q .F I=I:-1:J Q:'$D(@DDBSA@(I,0)) D ..X IOXY ..W IORI,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I,0),I) ..S DDBL=DDBL-1 F I=I:-1:J Q:I'>0!('$D(@DDBSA@(I))) D .X IOXY .W IORI,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I),I) .S DDBL=DDBL-1 D:K'=DDBL RLPI Q PD N I,J,K S I=DDBL+1,J=DDBL+DDBSRL,K=DDBL S DX=0,DY=$P(DDBSY,";",3) X IOXY I DDBZN D D:K'=DDBL RLPI Q .F I=I:1:J Q:'$D(@DDBSA@(I,0)) W !,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I,0),I) S DDBL=DDBL+1 .Q F I=I:1:J Q:'$D(@DDBSA@(I)) W !,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I),I) S DDBL=DDBL+1 D:K'=DDBL RLPI Q LU N I S I=DDBL-DDBSRL S DX=0,DY=$P(DDBSY,";",2) X IOXY I DDBZN Q:'$D(@DDBSA@(I,0)) S DDBL=DDBL-1 W IORI,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I,0),I) D RLPIR Q I I>0,$D(@DDBSA@(I)) S DDBL=DDBL-1 W IORI,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I),I) D RLPIR Q Q LD S DX=0,DY=$P(DDBSY,";",3) X IOXY I DDBZN,$D(@DDBSA@(DDBL+1,0)) D Q .S DDBL=DDBL+1 .W !,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(DDBL,0),DDBL) .D RLPIR .Q I 'DDBZN,$D(@DDBSA@(DDBL+1)) D Q .S DDBL=DDBL+1 .W !,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(DDBL),DDBL) .D RLPIR .Q Q COL(N) N X S X=$O(@DDBC@(DDBSF),N) Q:X'>0 S DDBSF=X COLENT S DDBST=DDBSF+(IOM-1),DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL) D SDLR(DDBL+1),COLR I DDBHDRC D ENCHDR^DDBR4 Q COLJ N X COLA S X(2)="Col> " W $$WS^DDBR1(.X) D G:X=""!(X=U) OUT .D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,"",100,1,"","KPW",.X) .K DIR0 .Q I $E(X)="?" G COLERR I X<1!(X>255) W $C(7) G COLERR S DDBSF=X G COLENT Q COLERR S X(1)=" * [ "_$$EZBLD^DIALOG(836)_" ] *" ;**'Enter a number between 1 and 255' G COLA OUT D PSR^DDBR0() Q RLE Q:$G(DDBRHTF) S DDBSF=1 G COLENT RRE Q:$G(DDBRHTF) S DDBSF=$O(@DDBC@(""),-1) G COLENT ; ONLINE Q RR I DDBRHTF D JUMP^DDBRAHTJ(1) Q D COL(1) Q RL I DDBRHTF D JUMP^DDBRAHTJ(-1) Q D COL(-1) Q TOP S DDBL=0 D SDLR(1),RLPIR Q BOT I DDBTL>DDBSRL S DDBL=DDBTL-DDBSRL D SDLR(DDBL+1),RLPIR Q EXIT S DDBRE="^" Q TO S DDBTO=DDBTO+1,DDBE=-1 S:DDBTO'<($G(DTIME,300)\5) DDBE="^" Q RCLSI D RLPIR,COLR Q PSR(PSR) S DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL) D:$G(PSR) HFR D SDLR(DDBL+1),RLPIR,COLR Q SDL ; SDLR(L) N I,J,SFR,STO S DX=0,SFR=$P(DDBSY,";",2),STO=$P(DDBSY,";",3),J=L S DY=SFR X IOXY I DDBZN F I=SFR:1:STO D .W:I'=SFR ! .W $P(DDGLCLR,DDGLDEL) .I J=L,$D(@DDBSA@(L)) W $$HTD(@DDBSA@(L,0),L) S DDBL=DDBL+1,L=L+1 .S J=J+1 .Q I 'DDBZN F I=SFR:1:STO D .W:I'=SFR ! .W $P(DDGLCLR,DDGLDEL) .I J=L,$D(@DDBSA@(L)) W $$HTD(@DDBSA@(L),L) S DDBL=DDBL+1,L=L+1 .S J=J+1 .Q Q HFR N FTR S FTR=1 HDR S DX=0 S DY=$P(DDBSY,";") X IOXY W $P(DDGLVID,DDGLDEL,6) W DDBHDR W $P(DDGLVID,DDGLDEL,10) G:$G(FTR) FTR Q FTR I DDBFLGS Q W $P(DDGLVID,DDGLDEL,6) I DDBRSA=1 W $P(DDGLVID,DDGLDEL,4) S DY=$P(DDBSY,";",4) X IOXY W DDBFTR S DX=$P(DDBSX,";",3) X IOXY W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL),6)," of ",DDBTL S DX=$P(DDBSX,";",4) X IOXY W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL-1\DDBSRL+1),5)," of ",DDBTL\DDBSRL+(DDBTL#DDBSRL'<1) S DX=$P(DDBSX,";",2) X IOXY W:'DDBRHTF $J(DDBSF,4) I DDBRSA=1 W $P(DDGLVID,DDGLDEL,10) W $P(DDGLVID,DDGLDEL,10) Q RLPI ; RLPIR I DDBFLGS Q S DX=$P(DDBSX,";",3),DY=$P(DDBSY,";",4) I DDBRSA=1 W $P(DDGLVID,DDGLDEL,4) W $P(DDGLVID,DDGLDEL,6) X IOXY W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL),6) S DX=$P(DDBSX,";",4) X IOXY W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL-1\DDBSRL+1),5) I DDBRSA=1 W $P(DDGLVID,DDGLDEL,10) W $P(DDGLVID,DDGLDEL,10) Q COLR I DDBFLGS!(DDBRHTF) Q S DX=$P(DDBSX,";",2),DY=$P(DDBSY,";",4) X IOXY I DDBRSA=1 W $P(DDGLVID,DDGLDEL,4) W $P(DDGLVID,DDGLDEL,6) W $J(DDBSF,4) I DDBRSA=1 W $P(DDGLVID,DDGLDEL,10) W $P(DDGLVID,DDGLDEL,10) Q ; HTD(X,WPIEN) ; Q:'DDBRHTF $E(X,DDBSF,DDBST) Q:$L(X,"$.")'>2 X S:$L(X,"$.$")>2 X=$$HT(X,"$.$","","") S:$L(X,"$.%")>2 X=$$HT(X,"$.%",$P(DDGLVID,DDGLDEL),$P(DDGLVID,DDGLDEL,3)) Q X ; HT(Y,D,C1,C2) ; Q:$L(Y,D)'>2 Y N YL,I,Y1 S YL=$L(Y,D),Y1="" F I=1:1:YL D .S:I#2 Y1=Y1_$P(Y,D,I) .I '(I#2),+$G(DDBRHT)=WPIEN,$P(DDBRHT,DDGLDEL,4)=DDBSA,$P(DDBRHT,DDGLDEL,2)=$P(Y,D,I) D Q ..S Y1=Y1_C1_$P(DDGLVID,DDGLDEL,4)_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_$P(DDGLVID,DDGLDEL,5)_C2 ..Q .S:'(I#2) Y1=Y1_C1_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_C2 .Q Q Y1 DDBR1^INT^1^60300,29508^0 DDBR1 ;SFISC/DCL-VA FILEMAN BROWSER PROTOCOLS ;06:01 PM 31 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 Q GOTO N X GTR S X(1)=$G(X(1)),X(2)=$$EZBLD^DIALOG(1408)_" >" W $$WS(.X) D G:X=""!(X=U) OUT ;** .D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,"",100,"","","KPW",.X) .K DIR0 .Q I $E(X)="?" S X(1)="* "_$$EZBLD^DIALOG($S(DDBRHTF:1409,1:1409.1))_" *" G GTR ;** I X S X=X*DDBSRL G LINE S $E(X)=$TR($E(X),"bclst","BCLST") I X["S",$TR($P(X,"S",2)," ") S X=$TR($P(X,"S",2)," ")*DDBSRL G LINE I X["L",$TR($P(X,"L",2)," ") S X=$TR($P(X,"L",2)," ") G LINE I X["C",'DDBRHTF,$TR($P(X,"C",2)," ") S X=$TR($P(X,"C",2)," ") I X>0&(X<256) S DDBSF=X G COLENT^DDBR0 I $E(X)="T" G TOP^DDBR0 I $E(X)="B" G BOT^DDBR0 G OUT LINE S DDBL=$S(X'>DDBSRL:0,X>DDBTL:DDBTL,1:X) D PSR^DDBR0() Q NOOF N N S N=1 I $D(DDBFNO) N D,X G FNO S X(1)=" * ["_$$EZBLD^DIALOG(1406)_"] *" ;**'NO PREVIOUS FIND STRING AVAILABLE' N Q S N=0 G BPR FIND N D,Q,X N N S N=0 BPR S X(1)=$G(X(1)),X(2)=$$EZBLD^DIALOG(8126) W $$WS(.X) D G:X="" OUT ;** .N Y .D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,$P($G(DDBFNO),U,3,255),100,"","","KPW",.X,.Y) .K DIR0 .S:$P($G(Y),U)="U" X=X_"/U" .Q S Q=$TR($E(X,$L(X)-1,$L(X)),"u","U") S D=$S(Q="/U":-1,1:1) S:D=-1 X=$E(X,1,$L(X)-2) Q:X="" I $E(X)="?" S X(1)=" * [ "_$$EZBLD^DIALOG(1407)_" ] *" G BPR ;** FNO N I,MATCHI,MATCHX I N S D=$P(DDBFNO,"^",2),X=$P(DDBFNO,"^",3,255) S X(1)="",X(2)=" * ["_$$EZBLD^DIALOG(1405,X)_"] *" W $$WS(.X) ;**'SEARCHING' D S:I<0 I=0 .I N&(D=1) S I=DDBL Q .I N S I=DDBL-(DDBSRL-1) Q .I D=1 S I=DDBL-DDBSRL Q .S I=DDBL+1 .Q D .N XUC .S XUC=$$U(X) .I DDBDM D Q ..I DDBZN D Q ...F S I=$O(^TMP("DDB",$J,I),D) Q:I'>0 I $$U($G(^(I,0)))[XUC S MATCHI=I,MATCHX=^(0) Q ...Q ..F S I=$O(^TMP("DDB",$J,I),D) Q:I'>0 I $$U(^(I))[XUC S MATCHI=I,MATCHX=^(I) Q ..Q .I DDBZN D Q ..F S I=$O(@DDBSA@(I),D) Q:I'>0 I $$U($G(@DDBSA@(I,0)))[XUC S MATCHI=I,MATCHX=@DDBSA@(I,0) Q ..Q .F S I=$O(@DDBSA@(I),D) Q:I'>0 I $$U(@DDBSA@(I))[XUC S MATCHI=I,MATCHX=@DDBSA@(I) Q .Q I $G(MATCHI) D S DDBFNO=DDBL_"^"_D_"^"_X Q .S DDBSF=1,DDBST=IOM F Q:$F(MATCHX,X)'>DDBST D ..S DDBSF=$O(@DDBC@(DDBSF)) S:DDBSF="" DDBSF=$O(@DDBC@("")) ..S DDBST=DDBSF+(IOM-1) ..Q .I I+(DDBSRL)>DDBTL S I=DDBTL-(DDBSRL-1) .I DDBTL'>DDBSRL S I=1 .S DDBL=I-1 D SDLRH(I,X),RCLSI^DDBR0 .Q NO S X(1)="",X(2)=" * ["_$$EZBLD^DIALOG($S(N:8006.11,1:8006.1))_" ] *" W $C(7),$$WS(.X) H 3 ;**'NO MATCH FOUND' D PSRH Q OUT D PSR^DDBR0() Q PSRH S DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL) D SDLRH(DDBL+1,X) Q SDL ; SDLRH(L,HLS) N I,J,SFR,STO S DX=0,SFR=$P(DDBSY,";",2),STO=$P(DDBSY,";",3),J=L S DY=SFR X IOXY I DDBZN F I=SFR:1:STO D .W:I'=SFR ! .W $P(DDGLCLR,DDGLDEL) .I J=L,$D(@DDBSA@(L)) W $$HL($$HTD^DDBR0(@DDBSA@(L,0),L),HLS,$P(DDGLVID,DDGLDEL,6),$P(DDGLVID,DDGLDEL,7)) S DDBL=DDBL+1,L=L+1 .S J=J+1 .Q I 'DDBZN F I=SFR:1:STO D .W:I'=SFR ! .W $P(DDGLCLR,DDGLDEL) .I J=L,$D(@DDBSA@(L)) W $$HL($$HTD^DDBR0(@DDBSA@(L),L),HLS,$P(DDGLVID,DDGLDEL,6),$P(DDGLVID,DDGLDEL,7)) S DDBL=DDBL+1,L=L+1 .S J=J+1 .Q Q HL(X,S,ON,RS,F) S X=$G(X),S=$G(S),F=$G(F)=1 G:F CS N C,I,P,T,XU,SU,SL,TL,XL S XU=$$U(X),SU=$$U(S),SL=$L(S),C=$L(XU,SU)-1,T="",XL=0 Q:'C X F I=1:1:C S P=$F(XU,SU,XL),T=T_$E(X,XL,P-SL-1)_ON_$E(X,P-SL,P-1)_RS,XL=P S T=T_$E(X,XL,255) Q T U(X) Q $$UP^DILIBF(X) ;**CCO/NI UPPER-CASE CS Q:$L(X,S)'>1 X N C,I,P,T S T="",C=$L(X,S) F I=1:1:C S P=$P(X,S,I),T=T_P_$S(I'=C:ON_S_RS,1:"") Q T HELPS N DDBHELPS S DDBHELPS=$S(DDBFLG["A":83,1:71)+DDBSRL HELP I $E(DDBSA,1,11)="^DI(.84,920" S DDBL=0 D SDLR^DDBR0(1),RLPIR^DDBR0 Q N DDBHA S DDBHA=$S(DDBFLG["A":9202,1:9201) Q:'$D(^DI(.84,DDBHA,2)) S DDBHA=$NA(^(2)) I $G(DUZ("LANG"))>1,$D(^(4,DUZ("LANG"),1)) S DDBHA=$NA(^(1)) ;**CCO/NI I $D(^TMP("DDBLST",$J,"J")) D .K ^TMP("DDBLST",$J,"JS") .M ^TMP("DDBLST",$J,"JS")=^TMP("DDBLST",$J,"J") .K ^TMP("DDBLST",$J,"J") .Q D BROWSE^DDBR(DDBHA,"PNH"_$S(DDBFLG["A":"A",1:""),"VA FileMan Help Document",$G(DDBHELPS),"",IOTM-1,IOBM+1) K ^TMP("DDBLST",$J,"J") I $D(^TMP("DDBLST",$J,"JS")) M ^TMP("DDBLST",$J,"J")=^TMP("DDBLST",$J,"JS") K ^TMP("DDBLST",$J,"JS") W @IOSTBM D PSR^DDBR0(1) Q LC(L,C) Q:$G(L)'>0 "" S C=$G(C,"-") Q $TR($J("",L)," ",C) WS(X) S DX=0,DY=$P(DDBSY,";",3)-3 X IOXY W $P(DDGLGRA,DDGLDEL) W $TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3)) W $P(DDGLGRA,DDGLDEL,2) W !,$P(DDGLCLR,DDGLDEL),$G(X(1)) W !,$P(DDGLCLR,DDGLDEL),$G(X(2)) W !,$P(DDGLCLR,DDGLDEL),$G(X(3)) S DY=$P(DDBSY,";",3),DX=$L($G(X(2)))+2 X IOXY Q "" DDBR2^INT^1^60300,29508^0 DDBR2 ;SFISC/DCL-VA FILEMAN BROWSER ;06:34 PM 31 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 Q SWITCH(DDBLST,DDBRET) ;Switch to another document in list or FileMan Database I $E(DDBSA,1,11)="^DI(.84,920" D EXIT^DDBR0 Q ;!(DDBSA="^XTMP(""DDBDOC"")") Q I DDBSA=$NA(^TMP("DDWB",$J)) G EXIT^DDBR0:$G(DDBRET)["R",SWITCH^DDBRWB Q N DDBLN,DDBZ,DIC,DIR,X,Y,DIRUT,DIROUT,DUOUT,DILN S DILN=DDBRSA(DDBRSA,"DDBSRL")-2 S:$G(DDBLST)="" DDBLST="^TMP(""DDBLST"",$J)" S DDBLN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1) I DDBFLG["R",'$D(@DDBLST) D SFR() G PS I DDBFLG["A" D SFR() G PS I $G(DDBRET)["R" D G:$G(Y) PS Q .Q:DDBPSA'>0 .Q:'$D(@DDBLST@("APSA",DDBPSA)) S X=^(DDBPSA) S:$D(@DDBLST@("A",X)) Y=^(X) .I $G(Y) S DDBPSA=DDBPSA-1 N DDBPSA D SAVEDDB(DDBLST,DDBLN),USAVEDDB(DDBLST,+Y) .Q BRMC D BRM I $D(@DDBLST) D .I $O(@DDBLST@(" "),-1)=1,$G(@DDBLST@(1,"DDBSA"))=DDBSA Q .;W "Current list: ",! .S DDBZ=$G(@DDBLST@("A",DDBSA),0) .;S X=0 F S X=$O(@DDBLST@(X)) Q:X'>0 W:X'=DDBZ !,$J(X,3)," ",$E(@DDBLST@(X,0),1,75) .W ! .K DIR0 CUR .S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(8142),DIR("B")="YES" D ^DIR,SFR(1):Y=0&(DDBFLG["R") Q:$D(DIRUT)!(Y'>0) ;** .S DIC=$$OREF^DIQGU(DDBLST),DIC(0)="EMQ",DIC("S")="I +Y'=DDBZ",DIC("W")="W:$E(^(0))=U ^(0)",X="??" D ^DIC ;K DIC("S") Q:Y'>0 .S DIC(0)="AEMQ" .D ^DIC K DIC("S") Q:Y'>0 .D SAVEDDB(DDBLST,DDBLN),USAVEDDB(DDBLST,+Y) .S DIROUT=1 N DDBLNA S:DDBFLG["R" DIROUT=1 I '$D(DIROUT) D LIST^DDBR3(.DDBLNA) I $G(DDBLNA,-1)=-1 G PS I $G(DDBLNA(6))=DDBSA G PS ;if current document selected again I $G(DDBLNA(6))]"",$D(@DDBLST@("APSA",DDBSA)) G PS ;if already in list NO I DDBLNA'>0 W $C(7),!!,$$EZBLD^DIALOG(1404),DDBLNA(5) H 3 ;** D:DDBLNA>0 SAVEDDB(DDBLST,DDBLN),WP(.DDBLNA) PS D PSR^DDBR0(1) Q ; WP(DDBX) ; S DDBSA=DDBX(6) S DDBPMSG=DDBX(5) S DDBHDR=$$CTXT^DDBR(DDBPMSG,$J("",IOM+1),IOM) S DDBTL=$P(@DDBSA@(0),"^",3) S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1) S DDBZN=1 S DDBDM=0 S DDBSF=1 S DDBST=IOM S DDBC="^TMP(""DDBC"",""DDBC"",$J)" I '$D(@DDBC) F I=1,22:22:176 S @DDBC@(I)="" S DDBL=0 Q ; SAVEDDB(DDBLIST,IEN,NSAPSA) ;Save local varialbes into ^TMP("DDBLIST",$J,IEN) ;DDBS array to save list ;IEN internal entry ;NSAPSA Not Set "APSA" x-ref if undefined, pass 1 to not set NSAPSA (optional - default is to set "APSA") S NSAPSA=+$G(NSAPSA) N I,X F I="HDR","HDRC","SA","ZN","DM","PMSG","L","C","TL","SF","ST","RE","RPE" S X="DDB"_I,@DDBLIST@(IEN,X)=@X ;I $D(DDBFNO) S @DDBLIST@(IEN,DDBFNO)=DDBFNO ;decided to keep it the same throughout the browse session (Next Find String) S @DDBLIST@(IEN,0)=DDBPMSG S:'$D(@DDBLIST@(0)) ^(0)="CURRENT LIST^1" S:'$D(@DDBLIST@("A",DDBSA)) @DDBLIST@("A",DDBSA)=IEN S:'$D(@DDBLIST@("B",DDBPMSG,IEN)) @DDBLIST@("B",DDBPMSG,IEN)="" I $G(DDBRET)["R",DDBRPE=DDBRE Q Q:NSAPSA S X=$O(@DDBLST@("APSA"," "),-1)+1 I $G(@DDBLIST@("APSA",X-1))=DDBSA S DDBPSA=X-1 Q S @DDBLIST@("APSA",X)=DDBSA,DDBPSA=X Q ; USAVEDDB(DDBLIST,IEN) ;Unsave varialbes in ^TMP("DDBLIST",$J,IEN) to locals ;DDBS array to save list ;IEN internal entry N I,X F I="HDR","HDRC","SA","ZN","DM","PMSG","L","C","TL","SF","ST","RE","RPE" S X="DDB"_I,@X=@DDBLIST@(IEN,X) S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1) ;I $D(@DDBLIST@(IEN,"DDBFNO")) S DDBFNO=@DDBLIST@(IEN,"DDBFNO") Q ; ; CTXT(X,T,W) ;Center X in T which is W characters wide (usually spaces) and W for screen width Q:X="" $G(T) N HW S W=$G(W,79),HW=W\2 S $E(T,HW-($L(X)\2),HW-($L(X)\2)+$L(X))=X Q T OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_"," OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 % S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q % ; BRM ;BROWSE MANAGER SCREEN N DX,DY,X S DX=0,DY=$P(DDBSY,";"),X=$$CTXT^DDBR("BROWSE SWITCH MANAGER",$J("",IOM+1),IOM) X IOXY W $P(DDGLVID,DDGLDEL,6) ;rvon W $P(DDGLVID,DDGLDEL,4) ;uon W X W $P(DDGLVID,DDGLDEL,10) ;rvoff F DY=$P(DDBSY,";",2):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL) W $P(DDGLVID,DDGLDEL,6) ;rvon W $P(DDGLVID,DDGLDEL,4) ;uon W X W $P(DDGLVID,DDGLDEL,10) ;rvoff W @IOSTBM S DY=$P(DDBSY,";",2) X IOXY Q ; SFR(Y) N X S X(1)="",X(2)=$$CTXT^DDBR("<< "_$$EZBLD^DIALOG($S($G(Y):7076.1,1:7076))_" >>","",IOM) ;** 'SWITCH FUNCTION RESTRICTED' W $$WS^DDBR1(.X),$C(7) R X:3 Q DDBR3^INT^1^60300,29508^0 DDBR3 ;SFISC/DCL-SELECT FILE & WP FIELD TO BROWSE ;NOV 04, 1996@13:48 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. LIST(DDBLIST) ;DDBLIST=Target array for file number,ien,field,... S DDBLIST=-1 ;no selection EN ; N %,%H,%ZISOS,A,D,D0,D1,DA,DDBB,DDBDDF,DDBDIC,DDBFRCD,DDBIEN,DDBRCR,DDBX,DIC,DICS,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL,DN,DX,I,POP,S,X,Y ;S DIC=1,DIC(0)="AEMQ" D ^DIC Q:+Y'>0 ;Select file D ^DICRW Q:Y'>0 S DIC="^DD("_+Y_",",DIC(0)="AEMQ" M S DIC("W")="I $P(^(0),U,2) W $S($P(^DD(+$P(^(0),U,2),.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")" S DIC("S")="I $P(^(0),U,2)" D ^DIC I +Y'>0,$D(@(DIC_"0,""UP"")")) S DIC="^DD("_+^("UP")_"," G M ;Select field/back out of multiples Q:+Y'>0 I $P(@(DIC_+Y_",0)"),U,2) S DIC="^DD("_+$P(^(0),U,2)_",",Y=.01 G D:$P(^DD(+$P(^(0),U,2),.01,0),U,2)["W",M D ; K DIC("S") S DDBDIC=$$UP^DIQGU(+$P(DIC,"^DD(",2),.DDBDIC),(DDBX,DDBIEN)="" S DDBFRCD=$$GET^DIQGDD(DDBDIC,"","NAME")_":[",DDBB=0 F S DDBX=$O(DDBDIC(DDBX)) Q:DDBX'<0 D Q:$G(Y)'>0 .K DA D IEN(","_DDBIEN,.DA) .S DIC=$$ROOT^DIQGU(+DDBDIC(DDBX),","_DDBIEN),DIC(0)="AEMQ" Q:DIC']"" .S DDBRCR=$$CREF^DILF(DIC) .I $P($G(@DDBRCR@(0)),U,4)'>0 D K DDBIEN Q ..W $C(7),!!,"No Records at "_$S(DDBDIC=+DDBDIC(DDBX):"FILE",1:$P(^DD(+DDBDIC(DDBX),.01,0),U))_" Level.",! ..Q .D ^DIC I Y'>0 K DDBIEN Q .S DDBIEN=+Y_","_DDBIEN .S DDBFRCD=DDBFRCD_$S(DDBB:"\",1:"")_$$GET^DIQG(+DDBDIC(DDBX),DDBIEN,.01),DDBB=1 .K DA D IEN(DDBIEN,.DA) .Q DISP ; S DDBDDF=$O(^DD(+DDBDIC(-1),"SB",+DDBDIC(0),"")) Q:'DDBDDF S DDBFRCD=DDBFRCD_"] (wp): "_$P(^DD(DDBDIC(0),.01,0),"^") I $D(DDBIEN) D Q .N DDBX S DDBX=$P($$GET^DIQG(+DDBDIC(-1),DDBIEN,DDBDDF,"B"),"$CREF$",2) .S DDBLIST=$D(@DDBX) .S DDBLIST(1)=+DDBDIC(-1) .S DDBLIST(2)=DDBIEN .S DDBLIST(3)=DDBDDF .S DDBLIST(4)="N" .S DDBLIST(5)=DDBFRCD .S DDBLIST(6)=DDBX .Q Q IEN(IEN,DA) S DA=$P(IEN,",") N I F I=2:1 Q:$P(IEN,",",I)="" S DA(I-1)=$P(IEN,",",I) Q DDBR4^INT^1^60300,29508^0 DDBR4 ;SFISC/DCL-LOAD CURRENT LIST ;NOV 04, 1996@13:49 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. LOADCL(DDBSA,DDBFLG,DDBPMSG,DDBL,DDBC,DDBLST) ; ;DDBSA=source array by value ;DDGFLG=no flags currently available ;DDBPMSG=text to be displayed (centered) on top line ;DDBL=display line default 1st screen/line (22 in most cases) ;DDBC=location of column tab array used with right/left arrow keys ;DDBLST=location of current list (BROWSER expects ^TMP("DDBLST",$J)) I $G(DDBSA)']"" N X S X(1)="SOURCE ARRAY("_DDBSA_")" D BLD^DIALOG(202,.X) Q I '$D(@DDBSA) N X S X(1)="SOURCE ARRAY("_DDBSA_")" D BLD^DIALOG(202,.X) Q N DDBRE,DDBLN,DDBRPE,DDBPSA,DDBTO,I,X,Y N DDBFNO,DDBDM,DDBSF,DDBTL,DDBTPG,DDBZN,DDBFTR,DDBHDR,DDBHDRC,DDBST S DDBHDR=$$CTXT($G(DDBPMSG,"VA FileMan Browser"),$J("",IOM+1),IOM) S DDBHDRC=+$G(DDBHDRC) S DDBTL=$P($G(@DDBSA@(0)),"^",3) S:DDBTL'>0 DDBTL=$O(@DDBSA@(" "),-1) I DDBTL'>0 D I DDBTL'>0 D BLD^DIALOG(1700,"*NO TEXT* "_DDBSA) Q .N I S I=0 F S I=$O(@DDBSA@(I)) Q:I'>0 S DDBTL=I .Q S DDBZN=$D(@DDBSA@(DDBTL,0))#2,DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1),DDBDM=DDBSA="^TMP(""DDB"",$J)",DDBSF=1 S DDBC=$G(DDBC,"^TMP(""DDBC"",$J)") S DDBPSA=0,DDBFLG=$G(DDBFLG) S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL S (DDBRE,DDBRPE)="",DDBTO=0,DDBST=IOM S DDBLST=$G(DDBLST,"^TMP(""DDBLST"",$J)"),DDBLN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1) D SAVEDDB^DDBR2(DDBLST,DDBLN,1) Q ; CTXT(X,T,W) ;Center X in T which is W characters wide (usually spaces) and W for screen width Q:X="" $G(T) N HW S W=$G(W,79),HW=W\2 S $E(T,HW-($L(X)\2),HW-($L(X)\2)+$L(X))=X Q T OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_"," OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 % S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q % ; CHDR(D) ;Change Header Message in Window Title ;D=direction 1 is down, -1 is up, if 0 restore back to original msg. N C S C=DDBHDRC+D I C<0!(C>DDBTL) W $C(7) Q S DDBHDRC=C ENCHDR I 'DDBHDRC S DDBHDR=$$CTXT^DDBR(DDBPMSG,$J("",IOM+1),IOM) E D .I DDBZN S DDBHDR=$$CTXT^DDBR($E(@DDBSA@(DDBHDRC,0),DDBSF,DDBST)_$J("",IOM+1),"",IOM) Q .S DDBHDR=$$CTXT^DDBR($E(@DDBSA@(DDBHDRC),DDBSF,DDBST)_$J("",IOM+1),"",IOM) .Q I DDBRSA S DDBRSA(DDBRSA,"DDBHDRC")=DDBHDRC,DDBRSA(DDBRSA,"DDBHDR")=DDBHDR ; repaint screen D RPS^DDBRGE Q DDBRAHT^INT^1^60300,29508^0 DDBRAHT ;SFISC/DCL-BROWSER ANCHOR & HYPERTEXT PROCESSOR ;NOV 04, 1996@13:50 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. Q TAB ; S DDBRHT=$G(DDBRHT) I $P(DDBRHT,DDGLDEL,4)'=DDBSA S DDBRHT="" N LIM,ULCLR,ULNEW S LIM=DDBL,ULCLR=DDBRHT'>0,ULNEW=0 PSR S DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL) D SDLR(DDBL+1) Q SDLR(L) N I,J,SFR,STO I +DDBRHTLIM) S DDBRHT="",ULCLR=1 S DX=0,SFR=$P(DDBSY,";",2),STO=$P(DDBSY,";",3) S DY=SFR X IOXY F I=SFR:1:STO D .I $D(@DDBSA@(L)) S X=$S(DDBZN:@DDBSA@(L,0),1:@DDBSA@(L)),DDBL=DDBL+1,L=L+1 .E Q .I ULCLR,ULNEW Q .Q:$L(X,"$.%")'>2 .S WRF=0,J=$P(X,"$.%",$P(DDBRHT,DDGLDEL,3)),X=$$HTD(X,L-1) .I +DDBRHT,J=$P(DDBRHT,DDGLDEL,2) S ULCLR=1,WRF=1 .Q:'WRF .S DY=I .X IOXY .W $P(DDGLCLR,DDGLDEL),X .Q ; I 'ULNEW S DDBRHT="" Q ; HTD(X,WPIEN) ;text Q:'DDBRHTF $E(X,DDBSF,DDBST) Q:$L(X,"$.")'>2 X S:$L(X,"$.$")>2 X=$$HT(X,"$.$","","","","","","") S:$L(X,"$.%")>2 X=$$HT(X,"$.%",$P(DDGLVID,DDGLDEL),$P(DDGLVID,DDGLDEL,3),WPIEN'<+DDBRHT,$S(WPIEN=+DDBRHT:$P(DDBRHT,DDGLDEL,3)+2,1:2),$P(DDGLVID,DDGLDEL,4),$P(DDGLVID,DDGLDEL,5)) Q X ; HT(Y,D,C1,C2,UF,UP,U1,U2) ; Q:$L(Y,D)'>2 Y N YL,I,Y1 S YL=$L(Y,D),Y1="" F I=1:1:YL D .S:I#2 Y1=Y1_$P(Y,D,I) .I UF,I=UP,'ULNEW D Q ..S Y1=Y1_C1_U1_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_U2_C2,ULNEW=1,WRF=1 ..S DDBRHT=WPIEN_DDGLDEL_$P(Y,D,I)_DDGLDEL_I_DDGLDEL_DDBSA .S:'(I#2) Y1=Y1_C1_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_C2 .Q Q Y1 DDBRAHTE^INT^1^^0 DDBRAHTE ;SFISC/DCL-BROWSER ANCHOR & HYPERTEXT JUMP EDIT ;NOV 04, 1996@13:51 ;;22.0;VA FileMan;**145**;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. Q REDIT ; root edit for hypertext jump - CLOSED_ROOT Q ;prototype - phasing out Q:'$$CHKI N DDBSAN,DDBSANS,DDBSANX,DDBSANR,X S DDBSAN=$$NROOT^DDBRAP(DDBSA),DDBSANX=$P(DDBRHT,DDGLDEL,2) S X(1)=" < Edit Hypertext Jump Closed_Root >" S DDBSANS=$G(@DDBSAN@("H",DDBSANX)),DDBSANR=$G(@DDBSAN@("H",DDBSANX,0)) Q:DDBSAN=""!(DDBSANS="") GTR S X(1)=$G(X(1)),X(2)=" "_$E(DDBSANX,1,30)_" >" W $$WS^DDBR1(.X) D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,44,1,DDBSANR,100,1,"","KPW",.X) K DIR0 I $E(X)="?" S X(1)="* Enter closed_root jump for hypertext: "_$E(DDBSANX,1,35)_$S($L(DDBSANX)>35:"...",1:"")_" *" G GTR I DDBSANR'=X S @DDBSAN@("H",DDBSANX,0)=X G OUT ; IEDIT ; interactive edit/switch Q:'$$CHKI Q ANCH ; enter Anchor for jump Q ;prototype - phasing out Q:'$$CHKI N DDBSAN,DDBSANS,DDBSANX,DDBSANR,DDBSANCH,X S DDBSAN=$$NROOT^DDBRAP(DDBSA),DDBSANX=$P(DDBRHT,DDGLDEL,2) S X(1)=" < Edit Anchor Jump >" S DDBSANS=$G(@DDBSAN@("H",DDBSANX)),DDBSANR=$G(@DDBSAN@("H",DDBSANX,0)) S DDBSANCH=$P(DDBSANS,"^",4) Q:DDBSAN=""!(DDBSANS="") AGTR S X(1)=$G(X(1)),X(2)=" "_$E(DDBSANX,1,30)_" >" W $$WS^DDBR1(.X) D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,44,1,DDBSANCH,100,1,"","KPW",.X) K DIR0 I $E(X)="?" S X(1)="* Enter FILE#;IEN;FIELD;ANCHOR for: "_$E(DDBSANX,1,35)_$S($L(DDBSANX)>35:"...",1:"")_" *" G AGTR I DDBSANCH'=X S $P(@DDBSAN@("H",DDBSANX),"^",4)=X G OUT Q ; TEDIT ; edit hypertext document title I 'DDBRHTF!($G(DUZ(0))'["@") Q N DDBSAN,DDBSANX,X S DDBSAN=$$NROOT^DDBRAP(DDBSA),DDBSANX=$G(@DDBSAN@("TITLE")) S X(1)=" < Edit Hypertext Document Title >" TGTR S X(1)=$G(X(1)),X(2)=" Title >" W $$WS^DDBR1(.X) D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,44,1,DDBSANX,100,1,"","KPW",.X) K DIR0 I $E(X)="?" S X(1)="* Enter Document Name for Title *" G TGTR I X'="^" D D RPS^DDBRGE Q .S @DDBSAN@("TITLE")=X .S DDBPMSG=X,DDBHDR=$$CTXT^DDBR(X,$J("",IOM+1),IOM) .Q G OUT ; CHKI() ;return 1 if ok 0 not ok to continue also init DDBRHT if undefined S DDBRHT=$G(DDBRHT) Q:DDBRHT="" 0 I 'DDBRHTF!($G(DUZ(0))'["@") Q 0 I $P(DDBRHT,DDGLDEL,4)'=DDBSA Q 0 I +DDBRHT>DDBL Q 0 I +DDBRHT<($S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)+1) Q 0 Q 1 ; OUT D PSR^DDBR0() Q ; RA ;Rebuild Anchors I 'DDBRHTF!($G(DUZ(0))'["@") Q N X,DDBSAN S DDBSAN=$$NROOT^DDBRAP(DDBSA) S X(1)="",X(2)=" < Rebuilding Anchor Index for HyperText Jumps >" W $$WS^DDBR1(.X) D WP^DDBRAP(DDBSA,"",$G(@DDBSAN@("TITLE"),DDBPMSG)) R X:2 G OUT DDBRAHTJ^INT^1^60300,29508^0 DDBRAHTJ ;SFISC/DCL-BROWSER HYPERTEXT JUMP ;06:39 PM 31 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 Q JUMP(DDBRDIR) ; pass direction 1/forward -1/backward ; ; N DDBSAN,DDBRAFLG,DDBLST S DDBSAN=$$NROOT^DDBRAP($NA(@DDBSA)),DDBLST=$NA(^TMP("DDBLST",$J)) I $G(DDBRDIR)=1 D FRWD Q D BCK Q FRWD ; forward Q:'$$CHKI N DDBRAHP,DDBRAHA,DDBSANX,DDBRAAH,DDBRAHL,DDBRSET,DIERM S DDBSANX=$P(DDBRHT,DDGLDEL,2),DDBRAAH=$P(DDBSANX,"^"),DDBRSET=1 ;jump to another root I DDBSANX["$CREF$" D G STKPT:DDBSANX]"" G PS^DDBR2 .N DDBRAB,DDBRABR,DDBLSTN,DDBRATR,DDBRANRT,DDBRXC2,DDBRXC3 .S DDBRATR=$P(DDBSANX,"$CREF$",2) .S DDBRAAH=$P($P(DDBSANX,"$CREF$",3),"^") .I DDBRATR="" S DDBRAAH="" Q .I $D(@DDBRATR)'>9,$E($G(@DDBRATR),1,5)="$XC$^" D Q:$D(@DDBRATR)'>9 ..N X,DDBRNR ..S DDBRXC3=$P(@DDBRATR,"$XC$^",3) ..S X(1)="",X(2)=$$CTXT^DDBR("Loading "_DDBRXC3,"",IOM),X(3)="" ..W $$WS^DDBR1(.X) ..S DDBRXC2=$P(@DDBRATR,"$XC$^",2) X DDBRXC2 ..I $D(@DDBRATR)'>9 Q ..I DDBRXC3]"" D WP^DDBRAP(DDBRATR,"",DDBRXC3) ..Q .I $D(@DDBRATR)'>9,$E($G(@DDBRATR),1,6)="$XCR$^" D W @IOSTBM Q ..N X,IOTM,IOBM,IOSTBM ..S DDBRXC2=$P(@DDBRATR,"$XCR$^",2),DDBSANX="" X DDBRXC2 ..W:$D(IOF) @IOF ..S X=0 X ^%ZOSF("RM") ..W $P(DDGLVID,DDGLDEL,8) ..Q .I '$D(@DDBRATR) S DDBRAAH="" Q .S DDBRANRT=$$NROOT^DDBRAP(DDBRATR) .I '$D(@DDBRANRT) D WP^DDBRAP(DDBRATR) .S DDBLSTN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1) .D SAVEDDB^DDBR2(DDBLST,DDBLSTN,1),SET .S DDBRSET=0 .S DDBRAAH=$P(DDBRAAH,"#",2),DDBRAFLG=1 .S DDBSA=DDBRATR,DDBSAN=DDBRANRT UP .S DDBPMSG=$G(@DDBSAN@("TITLE")) S:DDBPMSG="" DDBPMSG=$$UP^DILIBF($P(DDBSANX,"^",$L(DDBSANX,"^"))) ;** .D SAVSET .Q ;jump to another file, w-pDD#,entry:entry#anchor I DDBRAAH,DDBRAAH["@" D G STKPT .N DDBRAB,DDBRABR,DDBLSTN,DDBRATR,DDBRANRT .S DDBRAB=$P(DDBRAAH,"#") .I DDBRAB="" S DDBRAAH="" Q .S DDBRATR=$$GETR^DDBRAP($P(DDBRAB,"@"),$P($P(DDBRAB,"@",2),"#")) .I DDBRATR="" D Q ..S DDBRAAH="" ..I $G(DIERR) S DIERM=$$CTXT^DDBR($G(^TMP("DIERR",$J,+DIERR,"TEXT",1))) ..K DIERR,^TMP("DIERR",$J) ..Q .S DDBRANRT=$$NROOT^DDBRAP(DDBRATR) .I '$D(@DDBRANRT) D WP^DDBRAP(DDBRATR) .S DDBLSTN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1) .D SAVEDDB^DDBR2(DDBLST,DDBLSTN,1),SET .S DDBRSET=0 .S DDBRAAH=$P(DDBRAAH,"#",2),DDBRAFLG=1 .S DDBSA=DDBRATR,DDBSAN=DDBRANRT .S DDBPMSG=$G(@DDBSAN@("TITLE")) S:DDBPMSG="" DDBPMSG="HYPERTEXT JUMP ID#"_$O(@DDBLST@("J",""),-1)+1 .D SAVSET .Q ;jump to another entry in the same file, same level I DDBRAAH["#",$P(DDBRAAH,"#")]"" D .N DDBRAB,DDBRABR,DDBRAIEN,DDBLSTN,DDBRALEV,DDBRANRT .S DDBRAB=$P(DDBRAAH,"#") .I DDBRAB="" S DDBRAAH="" Q .S DDBRALEV="",DDBRABR=$$IENROOT^DDBRAP($NA(@DDBSA),.DDBRALEV) .S DDBRAIEN=$O(@DDBRABR@("B",DDBRAB,"")) .I 'DDBRAIEN S DDBRAAH="" Q .S DDBRANRT=$$NROOT^DDBRAP($NA(@DDBRABR@(DDBRAIEN,DDBRALEV))) .I '$D(@DDBRANRT) D WP^DDBRAP($NA(@DDBRABR@(DDBRAIEN,DDBRALEV))) .S DDBLSTN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1) .D SAVEDDB^DDBR2(DDBLST,DDBLSTN,1),SET .S DDBRSET=0 .S DDBRAAH=$P(DDBRAAH,"#",2),DDBRAFLG=1 .S DDBSA=$NA(@DDBRABR@(DDBRAIEN,DDBRALEV)) .S DDBSAN=DDBRANRT .S DDBPMSG=$G(@DDBSAN@("TITLE")) S:DDBPMSG="" DDBPMSG="HYPERTEXT JUMP ID#"_$O(@DDBLST@("J",""),-1)+1 .D SAVSET .Q STKPT S:DDBRAAH["#" DDBRAAH=$P(DDBRAAH,"#",2) I DDBRAAH]"" S DDBRAHA=$G(@DDBSAN@("A",DDBRAAH)) I DDBRSET,$G(DDBRAHA)'>0 D NOHTJ($G(DIERM)) G PS^DDBR2 S DDBRAHL=$S($G(DDBRAHA):DDBRAHA+DDBSRL-1,1:0) D SET:DDBRSET,GOTO Q Q ; SET ; set and save jump info S DDBRAHP=$O(@DDBLST@("J",""),-1)+1 S @DDBLST@("J",DDBRAHP)=DDBSA_DDGLDEL_DDBL_"^"_+$G(DDBLSTN)_DDGLDEL_DDBRHT Q ; GOTO ; jump to line in current document S DDBL=$S(DDBRAHL'>DDBSRL:0,DDBRAHL>DDBTL:DDBTL,1:DDBRAHL) D PSR^DDBR0(+$G(DDBRAFLG)) Q BCK ; backward Q:'$D(@DDBLST@("J")) N DDBX,DDBY,DDBRAFLG S DDBX=$O(@DDBLST@("J",""),-1),DDBY=@DDBLST@("J",DDBX) K @DDBLST@("J",DDBX) I $P(DDBY,DDGLDEL)'=DDBSA D S DDBRAFLG=1 .D USAVEDDB^DDBR2(DDBLST,$P($P(DDBY,DDGLDEL,2),"^",2)) S DDBL=+$P(DDBY,DDGLDEL,2),DDBRHT=$P(DDBY,DDGLDEL,3,255) D PSR^DDBR0(+$G(DDBRAFLG)) Q CHKI() ;return 1 if ok 0 not ok to continue also init DDBRHT if undefined S DDBRHT=$G(DDBRHT) Q:DDBRHT="" 0 I $P(DDBRHT,DDGLDEL,4)'=DDBSA Q 0 I +DDBRHT>DDBL Q 0 I +DDBRHT<($S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)+1) Q 0 Q 1 ; NOHTJ(EM) ; no hypertext jump available N X,Y S Y=$P(DDBSANX,"^",$S(DDBSANX["$CREF$":$L(DDBSANX,"^"),1:2)),X(1)=$$CTXT^DDBR(Y,"",IOM),EM=$G(EM) S:$P(EM,"Error:",2)]"" EM="<< "_$P(EM,"Error:",2)_" >>" S X(2)="" S X(3)=$$CTXT^DDBR($S(EM]"":EM,1:"<< "_$$EZBLD^DIALOG(7077)_" >>"),"",IOM) ;**NO HYPERTEXT JUMP W $$WS^DDBR1(.X),$C(7) R X:5 Q ; SAVSET ; S DDBHDR=$$CTXT^DDBR(DDBPMSG,$J("",IOM+1),IOM) S DDBTL=$P($G(@DDBSA@(0)),"^",3) S:DDBTL'>0 DDBTL=$O(@DDBSA@(" "),-1) S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1) S DDBZN=$D(@DDBSA@(DDBTL,0))#2 S DDBDM=0 S DDBSF=1 S DDBST=IOM S DDBC=$NA(^TMP("DDBC","DDBC",$J)) I '$D(@DDBC) F I=1,22:22:176 S @DDBC@(I)="" Q DDBRAHTR^INT^1^60300,29508^0 DDBRAHTR ;SFISC/DCL-BROWSER ANCHOR & HYPERTEXT PROCESSOR REVERSE TAB ;NOV 04, 1996@13:52 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. Q REVTAB ; Reverse Tab S DDBRHT=$G(DDBRHT) I $P(DDBRHT,DDGLDEL,4)'=DDBSA S DDBRHT="" N LIM,ULCLR,ULNEW S LIM=DDBL,ULCLR=DDBRHT'>0,ULNEW=0 PSR ;S DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL) D SDLR($S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)+1) Q SDLR(L) N I,J,SFR,STO I +DDBRHTLIM) S DDBRHT="",ULCLR=1 S DX=0,SFR=$P(DDBSY,";",3),STO=$P(DDBSY,";",2),L=L+DDBSRL F I=SFR:-1:STO S L=L-1 Q:$S(DDBZN:$D(@DDBSA@(L,0)),1:$D(@DDBSA@(L))) S (SFR,DY)=I X IOXY F I=SFR:-1:STO D .I $D(@DDBSA@(L)) S X=$S(DDBZN:@DDBSA@(L,0),1:@DDBSA@(L)),L=L-1 .E Q .I ULCLR,ULNEW Q .Q:$L(X,"$.%")'>2 .S WRF=0,J=$P(X,"$.%",$P(DDBRHT,DDGLDEL,3)),X=$$HTD(X,L+1) .I +DDBRHT,J=$P(DDBRHT,DDGLDEL,2) S ULCLR=1,WRF=1 .Q:'WRF .S DY=I .X IOXY .W $P(DDGLCLR,DDGLDEL),X .Q ; I 'ULNEW S DDBRHT="" Q ; HTD(X,WPIEN) ;text Q:'DDBRHTF $E(X,DDBSF,DDBST) Q:$L(X,"$.")'>2 X S:$L(X,"$.$")>2 X=$$HT(X,"$.$","","","","","","") S:$L(X,"$.%")>2 X=$$HT(X,"$.%",$P(DDGLVID,DDGLDEL),$P(DDGLVID,DDGLDEL,3),(WPIEN'>+DDBRHT!(DDBRHT="")),$S(WPIEN=+DDBRHT:$P(DDBRHT,DDGLDEL,3)-2,1:$L(X,"$.%")-1),$P(DDGLVID,DDGLDEL,4),$P(DDGLVID,DDGLDEL,5)) Q X ; HT(Y,D,C1,C2,UF,UP,U1,U2) ; Q:$L(Y,D)'>2 Y N YL,I,Y1 S YL=$L(Y,D),Y1="" F I=1:1:YL D .S:I#2 Y1=Y1_$P(Y,D,I) .I UF,I=UP,'ULNEW D Q ..S Y1=Y1_C1_U1_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_U2_C2,ULNEW=1,WRF=1 ..S DDBRHT=WPIEN_DDGLDEL_$P(Y,D,I)_DDGLDEL_I_DDGLDEL_DDBSA .S:'(I#2) Y1=Y1_C1_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_C2 .Q Q Y1 DDBRAP^INT^1^60300,29508^0 DDBRAP ;SFISC/DCL-BROWSER WP ANCHOR PROCESSOR ;06:56 PM 31 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 Q WP(DDBROOT,DDBRFLG,DDBRTLE) ; ;Pass existing wp root, flag=c/clear all -indexes, title I $G(DDBROOT)="" Q I '$D(@DDBROOT) Q S DDBROOT=$NA(@DDBROOT),DDBRFLG=$G(DDBRFLG),DDBRTLE=$G(DDBRTLE) N DDBRINDX,DDBRSUB,DDBRSUBL,DDBNROOT,DDBSROOT,DDBAXRT,DDBRCHK,DDBRCHK1 N DDBRSX,DDBRSXL,DDBRI,DDBRSXP,DDBRX,DDBRTLER S DDBRINDX=0,DDBNROOT=$$NROOT(DDBROOT),DDBAXRT=$NA(@DDBNROOT@("A")),DDBRCHK1=0 Q:DDBNROOT=""!(DDBAXRT="") K @DDBAXRT F S DDBRINDX=$O(@DDBROOT@(DDBRINDX)),DDBRCHK=1 Q:DDBRINDX'>0 D:$L($G(@DDBROOT@(DDBRINDX,0)),"$.$")>1 I DDBRCHK,$L($G(@DDBROOT@(DDBRINDX)),"$.$")>1 S DDBRCHK1=1 D .S DDBRCHK=0 .I DDBRCHK1 S DDBRSX=@DDBROOT@(DDBRINDX),DDBRSXL=$L(DDBRSX,"$.$") .E S DDBRSX=@DDBROOT@(DDBRINDX,0),DDBRSXL=$L(DDBRSX,"$.$") .F DDBRI=2:2:DDBRSXL S DDBRSXP=$P(DDBRSX,"$.$",DDBRI) S:'$D(@DDBAXRT@(DDBRSXP)) @DDBAXRT@(DDBRSXP)=DDBRINDX .Q S DDBRX="" I DDBRTLE]"" D .I '$D(@DDBNROOT@("TITLE")) S @DDBNROOT@("TITLE")=DDBRTLE .Q I $G(@DDBNROOT@("TITLE"))']"" D .Q:$$QL(DDBROOT)'>1 .S DDBRTLER=$NA(@DDBROOT,$$QL(DDBROOT)-1) .S DDBRTLE=$P($G(@DDBRTLER@(0)),"^") .I DDBRTLE]"" S @DDBNROOT@("TITLE")=DDBRTLE Q .Q S @DDBNROOT@("DATE")=$H Q ; NROOT(DDBROOT) ; *FUNCTION* return new (negative) root for wp field X-REF ;Q $NA(@DDBROOT@(.001)) ;tested ok Q $NA(@DDBROOT@(-1)) ;tested ok and in use ;Q $NA(@DDBROOT@(0,0)) ;tested ok ; BINDEX(DDBROOT,DDBRNR,DDBRNRN) ; *FUNCTION* return "B" index root N DDBRSUBL,DDBSROOT S DDBRSUBL=$$QL(DDBROOT) Q:DDBRSUBL'>1 "" S DDBSROOT=$NA(@DDBROOT,(DDBRSUBL-2)) S DDBRNR=DDBSROOT,DDBRNRN=$$QS(DDBROOT,DDBRSUBL) Q $NA(@DDBSROOT@("B")) ; IENROOT(DDBROOT,DDBRLEV) ;pass root,.variable~by reference to return ; $qs(ddbroot,$ql(ddbroot))~ N DDBRSUBL,DDBSROOT S DDBRSUBL=$$QL(DDBROOT) Q:DDBRSUBL'>1 "" S DDBRLEV=$$QS(DDBROOT,DDBRSUBL) Q $NA(@DDBROOT,(DDBRSUBL-2)) ; EN ;create anchors and jumps on existing wp entry N DDBC,DDBFLG,DDBL,DDBPMSG,DDBSA,DDBX,IOTM,IOBM I '$$TEST^DDBRT W $C(7),!!,$$EZBLD^DIALOG(830),!! Q ;** D LIST^DDBR3(.DDBX) I DDBX'>0 W:DDBX=0 $C(7),!!,$$EZBLD^DIALOG(1404),!! Q ;**NO TEXT S DDBSA=DDBX(6) S DDBFLG=DDBX(4) S DDBPMSG=DDBX(5) W !,"...." ;** D WP(DDBSA,$G(DDBRFLG),DDBPMSG) W !,"done!",! Q ; ENP ;create anchors & jumps and 'P'urge non-referenced jumps N DDBRFLG S DDBRFLG="P" G EN ; ENC ;create anchors and jumps and "C"lear out all jumps prior to building N DDBRFLG S DDBRFLG="C" G EN ; ; THE FOLLOWING CODE WAS COPIED FROM KERNEL'S XLFUTL ROUTINE QL(X) ;$QLENGTH OF GLOBAL STRING N %,%1 S %1="" F %=0:1 Q:%1=$NA(@X,%) S %1=$NA(@X,%) Q %-1 ; QS(X1,X2) ;$QSUBSCRIPT OF GLOBAL STRING N %,%1,Y I X2=-1,X1?1"^"1"[".E1"]".E Q $TR($P($P($NA(@X1,0),"]"),"[",2),"""") I X2=-1,X1?1"^"1"|".E1"|".E Q $TR($P($NA(@X1,0),"|",2,$L($NA(@X1,0),"|")-1),"""") I X2=0,(X1'?1"^"1"[".E)&(X1'?1"^"1"|".E) Q $NA(@X1,X2) I X2=0,X1?1"^"1"[".E1"]".E Q "^"_$P($NA(@X1,X2),"]",2,999) I X2=0,X1?1"^"1"|".E Q "^"_$P($NA(@X1,X2),"|",$L($NA(@X1,X2),"|")) S %1=$NA(@X1,X2-1) I $E(%1,$L(%1))=")" S %1=$E(%1,1,$L(%1)-1) S Y=$P($NA(@X1,X2),%1,2,999),Y=$E(Y,1,$L(Y)-1) I X2=1,$E(Y)="(" S Y=$E(Y,2,999) I X2>1,$E(Y)="," S Y=$E(Y,2,999) I $A(Y)=34,$A(Y,$L(Y))=34 S Y=$E(Y,2,$L(Y)-1) Q Y ; GETR(DDBRWPDD,DDBRENS,DDBRFLG) ;return root ;pass Word-processing DD#, entries (external format)[separated by(:)] ;ie.999008.02,ENTRYONE:SUBENTRY) ; N DDBRA,DDBROOT,DDBREL,DDBRLVLS,DDBRI,DDBREN,DDBRIEN,DDBRDA,DDBRX,DDBRDD,DDBREEN,X,Y Q:'$$UP^DIQGU(DDBRWPDD,.DDBRA) S DDBREL=$L(DDBRENS,":"),DDBRLVLS=$O(DDBRA("")),DDBREN=1,DDBRIEN="," I $G(DDBRFLG)'["I",$G(DUZ(0))'="@" D Q:$G(DIERR) "" .N DIFILE,DIAC,% .S DIFILE=+DDBRA(DDBRLVLS),DIAC="RD" .D ^DIAC .Q:% .D ERR("Read access denied, for file #"_DIFILE) .Q I ("-"_DDBREL)'=DDBRLVLS Q "" F DDBRI=DDBRLVLS:1:-1 D Q:$G(DIERR) .S DDBRDD=+DDBRA(DDBRI),DDBREEN=$P(DDBRENS,":",DDBREN),DDBREN=DDBREN+1 .D DA^DILF(DDBRIEN,.DDBRDA) .S DDBRIEN=","_+$$DIC($$ROOT^DILFD(DDBRDD,DDBRIEN),DDBREEN,.DDBRDA)_DDBRIEN .Q I $G(DIERR) K DIERR,^TMP("DIERR",$J) Q "" S DDBRX=$$GET^DIQG(+DDBRA(-1),$P(DDBRIEN,",",2,99),$O(^DD(+DDBRA(-1),"SB",+DDBRA(0),"")),"B") I $G(DIERR) K DIERR,^TMP("DIERR",$J) Q "" Q $P(DDBRX,"$CREF$",2) ; DIC(DIC,X,DA) ;dic call for exaxt match Q:DIC=""!(X="") "" S DIC(0)="X" S:$E(X)="`" DIC(0)="N" D ^DIC Q $G(Y) ; ERR(DDBERR) N P S P(1)=DDBERR I $G(U)="^" N U S U="^" D BLD^DIALOG(1700,.P) Q DDBRGE^INT^1^60300,29508^0 DDBRGE ;SFISC/DCL-BROWSE GET/EXECUTE EVENT ;NOV 04, 1996@13:52 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. EN N DDBGF D GETKEY S DDBRPE=0 W @IOSTBM S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL D PSR^DDBR0(1) S DX=0,DY=$P(DDBSY,";",3) X IOXY X DDGLZOSF("EOFF") F S DDBRE=$$READ D Q:DDBRE="^" .I $T(@DDBRE)="" W $C(7) Q .X DDGLZOSF("EON") .D @DDBRE .I DDBRSA S DDBRSA(DDBRSA,"DDBL")=DDBL .S DX=0,DY=$P(DDBSY,";",3) X IOXY .S DDBRPE=DDBRE .X DDGLZOSF("EOFF") X DDGLZOSF("EON") I $G(DDBFLG)["H" Q CLS S DX=0 F DY=$P(DDBSY,";"):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL) I DDBRSA S X=DDBL D .N DDBL S DDBL=X .D SR^DDBRS(DDBRSA,$S(DDBRSA=2:1,1:2),.DDBRSA) .W @IOSTBM .S DX=0 F DY=$P(DDBSY,";"):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL) .Q I $G(DDBC1),$G(DDBC0)]"" K @DDBC0@(1) K ^TMP("DDBC","DDBC",$J) S IOTM=1,IOBM=IOSL W @IOSTBM,$P(DDGLVID,DDGLDEL,9) D:'$D(DDS) KILL^DDGLIB0($G(DDBFLG)) S DX=0,DY=IOSL-1 X IOXY I DDBSRL+2=IOSL W @IOF D:$G(DDBFLG)'["P" KTMP END Q KTMP D KTMP^DDBRU Q READ() N S,Y F R *Y:DTIME D C Q:Y'=-1 Q Y C I Y<0 S Y="TO" Q ;I Y=13 S Y="COLR" Q S S="" C1 S S=S_$C(Y) I DDBGF("DDBIN")'[(U_S) D I Y=-1 W $C(7) Q . I $C(Y)'?1L S Y=-1 Q . S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDBGF("DDBIN")'[(U_S_U) Y=-1 I DDBGF("DDBIN")[(U_S_U),S'=$C(27) S Y=$P(DDBGF("DDBOUT"),U,$L($P(DDBGF("DDBIN"),U_S_U),U)) Q R *Y:5 G:Y'=-1 C1 W $C(7) Q GETKEY N AU,AD,AR,AL,F1,F2,F3,F4,I,K,N,T N FIND,SELECT,PREVSC,NEXTSC,HELP,KP7,KP8 S AU=$P(DDGLKEY,U,2) S AD=$P(DDGLKEY,U,3) S AR=$P(DDGLKEY,U,4) S AL=$P(DDGLKEY,U,5) S F1=$P(DDGLKEY,U,6) S F2=$P(DDGLKEY,U,7) S F3=$P(DDGLKEY,U,8) S F4=$P(DDGLKEY,U,9) S FIND=$P(DDGLKEY,U,10) S SELECT=$P(DDGLKEY,U,11) S PREVSC=$P(DDGLKEY,U,14) S NEXTSC=$P(DDGLKEY,U,15) S HELP=$P(DDGLKEY,U,16) S KP7=$P(DDGLKEY,U,25) S KP8=$P(DDGLKEY,U,26) F N="DDB" D . S DDBGF(N_"IN")="",DDBGF(N_"OUT")="" . F I=1:1 S T=$P($T(@(N_"MAP")+I),";;",2,999) Q:T="" D .. S @("K="_$P(T,";",2)) .. I DDBGF(N_"IN")'[(U_K) D ... S DDBGF(N_"IN")=DDBGF(N_"IN")_U_K ... S DDBGF(N_"OUT")=DDBGF(N_"OUT")_$P(T,";")_U . S DDBGF(N_"IN")=DDBGF(N_"IN")_U . S DDBGF(N_"OUT")=$E(DDBGF(N_"OUT"),1,$L(DDBGF(N_"OUT"))-1) Q TO S DDBRE="^" Q HELP D HELP^DDBR1 Q HELPS D HELPS^DDBR1 Q RETURN D SWITCH^DDBR2("","R") Q SWITCH D SWITCH^DDBR2() Q RPS I 'DDBRSA D PSR^DDBR0(1) Q N DDBRNI F DDBRNI=1,2 D .I DDBRSA=2 D SR^DDBRS(2,1,.DDBRSA) W @IOSTBM D PSR^DDBR0(1) Q .I DDBRSA=1 S DDBL=DDBRSA(DDBRSA,"DDBL") D SR^DDBRS(1,2,.DDBRSA) W @IOSTBM D PSR^DDBR0(1) Q .Q Q NEXT D NOOF^DDBR1 Q FIND D FIND^DDBR1 Q GOTO D GOTO^DDBR1 Q BOT D BOT^DDBR0 Q TOP D TOP^DDBR0 Q PD D PD^DDBR0 Q PU D PU^DDBR0 Q QUIT ; EXIT D EXIT^DDBR0 Q COLR D RR^DDBR0 Q COLL D RL^DDBR0 Q COLRE D RRE^DDBR0 Q COLLE D RLE^DDBR0 Q COLJ D COLJ^DDBR0 Q LND D LD^DDBR0 Q LNU D LU^DDBR0 Q HU D CHDR^DDBR4(-1) Q HD D CHDR^DDBR4(1) Q PH D PRTHELP^DDBRP Q STPB D STPB^DDBRWB Q VIEW D VIEW^DDBRWB Q AHT I DDBRHTF D TAB^DDBRAHT Q G BQT AHTR I DDBRHTF D REVTAB^DDBRAHTR Q G BQT TEHT I DDBRHTF D TEDIT^DDBRAHTE Q G BQT RA I DDBRHTF D RA^DDBRAHTE Q G BQT SCRN1 I DDBRSA=2 D SR^DDBRS(2,1,.DDBRSA) W @IOSTBM G RPS G BQT SCRN2 I DDBRSA=1 D SR^DDBRS(1,2,.DDBRSA) W @IOSTBM G RPS G BQT SPLIT I 'DDBRSA,$D(DDBRSA(1)) D SPLIT^DDBRS Q G BQT FULL I DDBRSA D FULL^DDBRS(.DDBRSA) Q G BQT RESIZU I DDBRSA,(DDBRSA(1,"IOBM")-1)>(DDBRSA(0,"IOTM")+2) S DDBRSA(1,"IOBM")=DDBRSA(1,"IOBM")-1,DDBRSA(2,"IOTM")=DDBRSA(2,"IOTM")-1 D 2,1,ENTB^DDBRS(.DDBRSA,-1) G RPS G BQT RESIZD I DDBRSA,(DDBRSA(2,"IOTM")+1)<(DDBRSA(0,"IOBM")-2) S DDBRSA(1,"IOBM")=DDBRSA(1,"IOBM")+1,DDBRSA(2,"IOTM")=DDBRSA(2,"IOTM")+1 D 1,2,ENTB^DDBRS(.DDBRSA,+1) G RPS G BQT BQT W $C(7) Q 1 S DX=0,DY=$P(DDBRSA(1,"DDBSY"),";",4) X IOXY W $P(DDGLCLR,DDGLDEL) Q 2 S DX=0,DY=$P(DDBRSA(2,"DDBSY"),";") X IOXY W $P(DDGLCLR,DDGLDEL) Q DDBMAP ; ;;LNU;AU; ;;LND;AD; ;;COLR;AR; ;;COLL;AL; ;;EXIT;F1_"E"; ;;QUIT;F1_"Q"; ;;PU;F1_AU; ;;PU;PREVSC; ;;PD;F1_AD; ;;PD;NEXTSC; ;;COLRE;F1_AR; ;;COLLE;F1_AL; ;;STPB;F1_"C"; ;;VIEW;F1_"V"; ;;TOP;F1_"T"; ;;BOT;F1_"B"; ;;GOTO;F1_"G"; ;;FIND;F1_"F"; ;;FIND;FIND; ;;NEXT;"N"; ;;NEXT;F1_"N"; ;;RPS;F1_"P"; ;;SWITCH;F1_"S"; ;;SWITCH;SELECT; ;;RETURN;"R"; ;;HELP;F1_"H"; ;;HELP;"HELP"; ;;HELPS;F1_F1_"H"; ;;EXIT;"EXIT"; ;;SCRN1;F2_AU; ;;SCRN2;F2_AD; ;;SPLIT;F2_"S"; ;;FULL;F2_"F"; ;;RESIZU;F2_F2_AU; ;;RESIZD;F2_F2_AD; ;;HU;F1_F1_AU; ;;HD;F1_F1_AD; ;;PH;F1_F1_F1_"H"; ;;STPB;F1_F1_"C"; ;;AHT;$C(9); ;;AHTR;"Q"; ;;TEHT;F4_"T"; ;;RA;F4_"A"; ;;COLR;$C(13); DDBRP^INT^1^60300,29508^0 DDBRP ;SFISC/DCL-BROWSER PRINT UTILITY ;06:05 PM 2 Sep 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 PRTHELP ; Print Help ; N DDGLI,DDGLHN1,DDGLHN2 S (DDGLHN1,DDGLHN2)=$S(DDBRHTF:9202,1:9201) ; BRM ;Clear scroll region, title bar and N DX,DY,X S DX=0,DY=$P(DDBSY,";"),X=$$CTXT^DDBR($$EZBLD^DIALOG(7076.4),$J("",IOM+1),IOM) ;**'PRINT BROWSER HELP' X IOXY W $P(DDGLVID,DDGLDEL,6) ;rvon W $P(DDGLVID,DDGLDEL,4) ;uon W X W $P(DDGLVID,DDGLDEL,10) ;rvoff F DY=$P(DDBSY,";",2):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL) W $P(DDGLVID,DDGLDEL,6) ;rvon W $P(DDGLVID,DDGLDEL,4) ;uon W X W $P(DDGLVID,DDGLDEL,10) ;rvoff W @IOSTBM S DY=$P(DDBSY,";",2) X IOXY ; ;Reset for Roll/Scroll mode S X=$G(IOM,80) X ^%ZOSF("RM") W $P(DDGLVID,DDGLDEL,9) ; N POP,XQH N IOF,IOSL,DDBUC,DDBLC,DDBRZIS N %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%K,%M,%N N %P,%S,%T,%W,%X,%Y,%XX,%YY N %A0,%D1,%D2,%DT,%J1,%W0 ; DEVICE ; S %ZIS=$S($D(^%ZTSK):"Q",1:""),%ZIS("B")="" S %ZIS("S")="I $$UP^DILIBF($P(^(0),U))'[""BROWSE"",$E($$GET1^DIQ(3.5,Y,""SUBTYPE""))=""P""" ;** S IOF="#",IOSL=DDBSRL D ^%ZIS K %ZIS ; I POP D .W !!,$$EZBLD^DIALOG(1901) ;**REPORT CANCELLED .H 2 ; ;Queue report E I $D(IO("Q")),$D(^%ZTSK) D .S ZTRTN="PRINTHLP^DDBRP" .S ZTDESC="Browser help printout." .N I F I="DDGLHN1","DDGLHN2" S ZTSAVE(I)="" .D ^%ZTLOAD QUEUED .I $D(ZTSK)#2 W !,$$EZBLD^DIALOG(8161,ZTSK),! ;** .E W !,$$EZBLD^DIALOG(1901),! ;**REPORT CANCELLED .K ZTSK .S IOP="HOME" D ^%ZIS ; E I $E(IOST,1,2)="C-" D G DEVICE .W !,$C(7)_$$EZBLD^DIALOG(7076.3),! ;**NOT ON CRT ; ;Non-queued report E D .W !,"..." ;** .U IO .D PRINTHLP .X $G(^%ZIS("C")) ; ;Reset for Screen Mode S X=0 X ^%ZOSF("RM") W $P(DDGLVID,DDGLDEL,8) ; ;Repaint help screen D RPS^DDBRGE Q ; PRINTHLP ; ; N DDGLJ,DDGLL,DDGLP F DDGLI=DDGLHN1:1:DDGLHN2 D . I DDGLI'=DDGLHN1 D .. I $Y+$O(^DI(.84,DDGLI,2," "),-1)+2'0:1,1:0) Q S TA(1,"DDBL")=TA(1,"DDBL")+$S(TA(1,"DDBL")DDBTL DDBL=DDBTL D PSR^DDBR0(1) Q ; SPLIT ;Split Screen N I F I="IOBM","IOTM","DDBSY","DDBSRL" S @I=DDBRSA(2,I) S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1) S I=1 D INIT("",.DDBRSA) W @IOSTBM S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL D PSR^DDBR0(1) D SR(2,1,.DDBRSA) W @IOSTBM S DDBL=DDBL-(DDBSRL+2),DDBRSA(1,"DDBL")=DDBL S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL D PSR^DDBR0(1) Q ; ;;NOTE: DDBRSA=0 - full screen ;; DDBRSA=1 - top of split screen ;; DDBRSA=2 - bottom of split screen DDBRT^INT^1^60300,29508^0 DDBRT ;SFISC/DCL-BROWSER TEST ROUTINE ;NOV 04, 1996@13:55 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. Q TEST() ;TEST IF CRT CAN USE BROWSER;USER MUST GO THRU ZU OR XUP FIRST Q:$G(IOST(0)) $$GET(+IOST(0)) Q:$G(IOS) $$GET($$GET1^DIQ(3.5,+IOS,"SUBTYPE","I")) Q:$G(^XUTL("XQ",$J,"IOST(0)")) $$GET(+^("IOST(0)")) Q:$G(^XUTL("XQ",$J,"IOS")) $$GET($$GET1^DIQ(3.5,+^("IOS"),"SUBTYPE","I")) Q 0 GET(DDBRTIEN) ; I $$GET1^DIQ(3.2,DDBRTIEN,"SET TOP & BOTTOM MARGINS")="" Q 0 I $$GET1^DIQ(3.2,DDBRTIEN,"REVERSE INDEX")="" Q 0 Q 1 DDBRU^INT^1^60300,29508^0 DDBRU ;SFISC/DCL-BROWSER UTILITIES AND EXTRINSIC FUNCTIONS ;2/27/99 11:57 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. CTRLCH() ;Extrinsic function - returns control characters 1-31 N I,X S X="" N I F I=1:1:31 S X=X_$C(I) Q X ; COL(DDBC) ;Set up colums used by Fileman Print Set DIOEND="D COL^DDBRU()" when calling Browser N H,I,P,Q,T,X S DDBC=$G(DDBC,"^TMP(""DDBC"",$J)") I $D(^TMP("DDBC",$J)) K ^($J) S X=0 F S X=$O(^UTILITY($J,99,X)) Q:X'>0 S T=^(X) D .S:T["D ^" H=$P(T,"^",2) .S Q=$L(T,"?") I Q>1 F I=1:1:Q S P=+$P(T,"?",I)+1 S @DDBC@(P)="" .Q I $G(H)]"" F X=1:1 S T=$T(@"HEAD"+X^@H) Q:T="" D .S Q=$L(T,"?") I Q>1 F I=1:1:Q S P=+$P(T,"?",I)+1 S @DDBC@(P)="" .Q Q ; KTMP K ^TMP("DDB",$J),^TMP("DDBC",$J) K ^TMP("DDBLST",$J) Q ; TRMERR(DDGLCH) ;Terminal type errors N P S P(1)=DDGLCH,P(2)=IOST D BLD^DIALOG(842,.P) Q ; RTN(RTN,TMPGBL) ; N I,F,X F I=1:1 S X=$T(+I^@RTN) Q:X="" S F=$F(X," ")-1,$E(X,F)=$E(" ",1,$S(F'>8:8-F,1:1)),@TMPGBL@(I)=$TR(X,$C(9)," ") Q ; RTNTB(DDBRTOP,DDBRBOT) ;PASS TOP AND BOTTOM MARGINS G DR ; ENDR N DDBENDR S DDBENDR=1 ; DR ;Display Routine(s) N DESC,RN,RSA,RTN,X,Y K ^TMP($J,"DDBDR"),^TMP($J,"DDBDRL"),^UTILITY($J) ;DR LIST X ^%ZOSF("RSEL") Q:$O(^UTILITY($J,""))']"" S RTN="",RN=1 F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="" D .S DESC=$P($P($T(+1^@RTN),";",2),"-",2),DESC=$S($L(DESC)>45:$E(DESC,1,45)_"...",1:DESC) .S RSA=$NA(^TMP($J,"DDBDR",RN)),RN=RN+1,^TMP($J,"DDBDRL",RTN_$E(" ",1,8-$L(RTN))_": "_DESC)=RSA .W !,"...loading ",RTN .D RTN^DDBRU(RTN,RSA) .Q W !,"...building ""Current List"" tables" D DOCLIST^DDBR("^TMP($J,""DDBDRL"")","",$G(DDBRTOP),$G(DDBRBOT)) K K ^TMP($J,"DDBDRL"),^TMP($J,"DDBDR"),^UTILITY($J) Q ; OUT ; D:'$D(DDS) KILL^DDGLIB0($G(DDBFLG)) D:$G(DDBFLG)'["P" KTMP Q ; RE(DDBRTN) G EDIT RTNEDIT N DDBRTN EDIT ;ROUTINE EDIT VIA VA FILEMAN SCREEN EDITOR ;EITHER PASS ROUTINE NAME RE^DDBRU("ROUTINE_NAME") OR USE ;RTNEDIT^DDBRU AND BE PROMPTED FOR ROUTINE NAME I '$D(^DD("OS",^DD("OS"),"ZS")) W !,"ROUTINE SAVE NODE NOT DEFINED IN MUMPS OPERATING SYSTEM FILE",! Q N DDBRI,DDBRX,X,Y,%,%X,%Y I $G(DDBRTN)]"" S X=DDBRTN X ^%ZOSF("TEST") I '$T W !,DDBRTN," Invalid",! X ^%ZOSF("EON") R:$G(DDBRTN)="" !,"Enter Routine> ",DDBRTN:DTIME I DDBRTN="" W !,"NO ROUTINE SELECTED",! Q S X=DDBRTN X ^%ZOSF("TEST") I '$T W !,"NO SUCH ROUTINE",! Q K ^TMP("DDBRTN",$J) W !,"Loading ",DDBRTN F DDBRI=1:1 S DDBRX=$T(+DDBRI^@DDBRTN) Q:DDBRX="" S ^TMP("DDBRTN",$J,DDBRI)=$$SP(DDBRX) D EDIT^DDW("^TMP(""DDBRTN"",$J)","M",DDBRTN,"Routine: "_DDBRTN) K ^UTILITY($J,0) S DDBRI=0,$P(^TMP("DDBRTN",$J,1),";",3)=$$NOW F S DDBRI=$O(^TMP("DDBRTN",$J,DDBRI)) Q:DDBRI'>0 S ^UTILITY($J,0,DDBRI)=$$TAB(^(DDBRI)) S X=DDBRTN X ^DD("OS",^DD("OS"),"ZS") K ^TMP("DDBRTN",$J),^UTILITY($J,0) X ^%ZOSF("EON") Q TAB(X) ;CONVERT 1ST SPACE TO TAB IF NO TAB N E,L,T S X=$G(X) Q:X="" "" S T=$C(9) Q:$E(X)=T X S L=$L(X) F E=1:1:L Q:$E(X,E)=T I $E(X,E)=" " S $E(X,E)=T D Q .S E=E+1 .F Q:$E(X,E)'=" " S $E(X,E)="" .Q Q X ; SP(X) ;MAKE SURE A TAB OR 1ST SPACE IS SET TO SPACES N E,L,S,SPS,T S X=$G(X) Q:X="" "" S S=8,$P(SPS," ",S)=" ",T=$E(9) I $E(X)=T S $E(X)=" " ;Q " "_X S L=$L(X) F E=1:1:L I $E(X,E)=" " D S $E(X,E)=$E(SPS,1,S-(E#S)) Q .S E=E+1 .F Q:$E(X,E)'=" " S $E(X,E)="" .S E=E-1 .Q Q X ; NOW() ; N %DT,X,Y S %DT="T",X="NOW" D ^%DT Q $$FMTE^DILIBF(Y,"1U") ; MSMCON ;MSM CONSOLE FOR 132/80 MODES ;OR VT TERMINALS 80 W $C(27),"[?",3,$C(108) S (IOM,X)=80 X ^%ZOSF("RM") Q 132 W $C(27),"[?",3,$C(104) S (IOM,X)=132 X ^%ZOSF("RM") Q DDBRU2^INT^1^60300,29508^0 DDBRU2 ;SFISC/DCL-BROWSE LOCAL OR GLOBAL ARRAY DDBROOT DESCENDANTS ;2AUG2004 ;;22.0;VA FileMan;**139**;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. Q EN N DDBNCC G CNTNU ROOT(DDBNCC,DDBRTOP,DDBRBOT) ; Browse Array Root Descendants ; DDBNCC node count check (default=1000) CNTNU K ^TMP("DDBARD",$J),^TMP("DDBARDL",$J) ;W !!,"Enter Root> " R DDBROOT W !! ;I DDBROOT="^"!(DDBROOT="") Q D ARSEL I $O(^TMP("DDBARDL",$J,""))']"" Q N DDBARDX,N,X S DDBARDX="",DDBNCC=$G(DDBNCC,1000) F S DDBARDX=$O(^TMP("DDBARDL",$J,DDBARDX)) Q:DDBARDX="" S X=^(DDBARDX) D .S N=$O(^TMP("DDBARD",$J,""),-1)+1 .S ^TMP("DDBARDL",$J,DDBARDX)=$NA(^TMP("DDBARD",$J,N)) .W !,"...loading ",DDBARDX .D BLD(DDBNCC,X,N) .Q W !,"...building ""Current List"" tables" D DOCLIST^DDBR("^TMP(""DDBARDL"",$J)","",$G(DDBRTOP),$G(DDBRBOT)) END K ^TMP("DDBARD",$J),^TMP("DDBARDL",$J) Q ; BLD(DDBNCC,DDBROOT,DDBN) ;build structures N DDBMAXL,DDBR1X S DDBMAXL=$G(DDBMAXL,255) S DDBNCC=$G(DDBNCC,1000) S DDBR1X=$$OREF^DIQGU(DDBROOT) N DDBR1,DDBR1A,DDBR1B,DDBR1I,DDBR1Q,DDBI,DDBII,DDBX,DDBX1,DDBX1L,DDBX2,DDBX2L,DDBX3,DDBX3L,DDBXT S DDBR1A=$$OREF^DIQGU($NA(@$$CREF^DIQGU(DDBR1X))),DDBR1Q="""""" I $L(DDBR1A,",")>1,$P(DDBR1A,",",$L(DDBR1A,","))]"" S DDBR1Q=$P(DDBR1A,",",$L(DDBR1A,",")),$P(DDBR1A,",",$L(DDBR1A,","))="" S DDBR1=DDBR1A_DDBR1Q_")",DDBR1B=$L(DDBR1A)+1,DDBX2=" = ",DDBX2L=$L(DDBX2),DDBII=0 F DDBI=1:1 S DDBR1=$Q(@DDBR1) Q:$P(DDBR1,DDBR1A)]""!(DDBR1="") D Q:DDBII .I '(DDBI#DDBNCC) D ..W $C(7),!,DDBROOT,!,"Node count: ",DDBI,!!,"Do you wish to continue //Yes " ..R DDBX:$G(DTIME,300) W !! ..I DDBX=""!($TR($E(DDBX),"y","Y")="Y") Q ..S DDBII=1 ..Q .S DDBX1=DDBR1 .S DDBX3=@DDBR1 .S DDBX1L=$L(DDBX1),DDBX3L=$L(DDBX3) .S DDBXT=DDBX1L+DDBX2L+DDBX3L .I DDBXT'>DDBMAXL S ^TMP("DDBARD",$J,DDBN,DDBI)=DDBX1_DDBX2_DDBX3 Q .I DDBX1L+DDBX2L'>DDBMAXL D Q ..S ^TMP("DDBARD",$J,DDBN,DDBI)=DDBX1_DDBX2_$E(DDBX3,1,DDBMAXL-(DDBX1L+DDBX2L)) ..S DDBI=DDBI+1 ..S ^TMP("DDBARD",$J,DDBN,DDBI)=$E(DDBX3,(DDBMAXL-(DDBX1L+DDBX2L)+1),DDBMAXL) ..Q .Q Q ; ARSEL ; Array Root Select N DDBERR,DDBRLVD,X,Y W !! SEL R !,"Select Root> ",X:$G(DTIME,300) I X="" Q I X="^" K ^TMP("DDBARDL",$J) Q I $E(X)="?" D HLP G SEL I X="^TMP"!(X="^TMP(")!($E(X,1,14)="^TMP(""DDBARDL""") D HLP G SEL S Y=$$OREF^DIQGU(X),DDBERR=0,Y=$$R(Y) I DDBERR W $C(7)," ...INVALID",!!,"'",X,"' CAN NOT BE RESOLVED",! G SEL S DDBRLVD=$$CREF^DIQGU(Y) S Y=$$CREF^DIQGU(X) I $D(@Y)'>9 S Y=$X W $C(7)," ...INVALID",!!,"'",X,"' HAS NO DESCENDANTS",! G SEL I DDBRLVD'=Y S X=X_" ["_DDBRLVD_"]" S ^TMP("DDBARDL",$J,X_" | DESCENDANTS |")=Y G SEL ; HLP ; W !!,"Enter a valid local or global array root" W !,"Can not be ^TMP, ^TMP( or ^TMP(""DDBARDL""",! Q ; R(%R) ; N %C,%F,%G,%I,%R1,%R2 S %R1=$P(%R,"(")_"(" I $E(%R1)="^" S %R2=$E($P(%R1,"("),2,99) D Q:$G(DDBERR) %R .I $L(%R2)'>0 S DDBERR=1 Q .I %R2="%" Q .I $E(%R2)="%" D Q ..I $E(%R2,2,99)?.E1P.E S DDBERR=1 Q ..Q .I %R2?1N.E S DDBERR=1 Q .I %R2?.E1P.E S DDBERR=1 Q .Q .;I %R2'="%"&(%R2'?.A) S DDBERR=1 Q %R I $E(%R1)'="^" S %R2=$P(%R1,"(") D Q:$G(DDBERR) %R .I $L(%R2)'>0 S DDBERR=1 Q .I %R2="%" Q .I $E(%R2)="%" D Q ..I $E(%R2,2,99)?.E1P.E S DDBERR=1 Q ..Q .I %R2?1N.E S DDBERR=1 Q .I %R2?.E1P.E S DDBERR=1 Q .Q .;,$E(%R1)'="%",$E(%R1)'?.A S DDBERR=1 Q %R I $E(%R1)="^" S %R2=$P($Q(@(%R1_""""")")),"(")_"(" S:$P(%R2,"(")]"" %R1=%R2 S %R2=$P($E(%R,1,($L(%R)-($E(%R,$L(%R))=")"))),"(",2,99) S %C=$L(%R2,","),%F=1 F %I=1:1 Q:%I'<%C S %G=$P(%R2,",",%F,%I) Q:%G="" I ($L(%G,"(")=$L(%G,")")&($L(%G,"""")#2))!(($L(%G,"""")#2)&($E(%G)="""")&($E(%G,$L(%G))="""")) D .S %G=$$S(%G),$P(%R2,",",%F,%I)=%G,%F=%F+$L(%G,","),%I=%F-1,%C=%C+($L(%G,",")-1) .Q S:'DDBERR DDBERR=%F'=%C Q %R1_%R2 S(%Z) ; I $G(%Z)']"" Q "" I $E(%Z)'="""",$L(%Z,"E")=2,+$P(%Z,"E")=$P(%Z,"E"),+$P(%Z,"E",2)=$P(%Z,"E",2) Q +%Z I +%Z=%Z Q %Z I $E(%Z)?1N,+%Z'=%Z S DDBERR=1 Q %Z I %Z="""""" Q "" I $E(%Z)="""" Q %Z I $E(%Z)'?1A,"%$+@"'[$E(%Z) S DDBERR=1 Q %Z I "+$"[$E(%Z) X "S %Z="_%Z Q $$Q(%Z) I $D(@%Z) Q $$Q(@%Z) S DDBERR=1 ;Unable to resolve a variable within a reference Q %Z Q(%Z) ; S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1) DDBRWB^INT^1^60300,29508^0 DDBRWB ;SFISC/DCL-VA FILEMAN BROWSER PROTOCOLS ;01:54 PM 3 Sep 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 Q STPB ; Save To Paste Buffer I DDBSA=$NA(^TMP("DDWB",$J)) D G PS^DDBR2 .N X .S X(1)="",X(2)=$$CTXT^DDBR($$EZBLD^DIALOG(7078.3),"",IOM) ;**RESTRICTED .W $$WS^DDBR1(.X),$C(7) .R X:5 .Q I $E(DDBSA,1,11)="^DI(.84,920" D G PS^DDBR2 .N X .S X(1)="",X(2)=$$CTXT^DDBR($$EZBLD^DIALOG(7078.4),"",IOM) ;**RESTRICTED .W $$WS^DDBR1(.X),$C(7) .R X:5 .Q N X,XF,XT GTR S X(1)=$G(X(1)),X(2)=$$EZBLD^DIALOG(7078) ;**COPY TEXT W $$WS(.X) D G:X=""!(X=U) OUT .D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,"",100,1,"","KPW",.X) .K DIR0 .Q I $E(X)="?" S X(1)=$$EZBLD^DIALOG(7078.1) G GTR ;**ENTER LINES I 'X&($E(X)'="*") G OUT I $E(X)="*" S X=$TR(X,"a","A"),XF=1,XT=DDBTL E S X=$TR(X,"a-/;|* ","A:::::"),XF=+X,XT=+$P(X,":",2) I XF<1!(XF>DDBTL) S X(1)=$$EZBLD^DIALOG(7078.2,DDBTL) G GTR ;**ERROR I XT,XT<1!(XT>DDBTL) S X(1)=$$EZBLD^DIALOG(7078.2,DDBTL) G GTR ;** I XT>0,XT0:XF,1:XT),X["A") K X S X(2)="Text Copied to Buffer" W $$WS(.X) R X:3 G OUT ; SAVE(FR,TO,APN) ; Save From To (lines) APN=append to end of current list K:'APN ^TMP("DDWB",$J) N I,II S II=$O(^TMP("DDWB",$J,""),-1)+1 I DDBZN D Q .F I=FR:1:TO S ^TMP("DDWB",$J,II)=@DDBSA@(I,0),II=II+1 .Q F I=FR:1:TO S ^TMP("DDWB",$J,II)=@DDBSA@(I),II=II+1 Q VIEW I DDBSA=$NA(^TMP("DDWB",$J)) S DDBL=0 D SDLR^DDBR0(1),RLPIR^DDBR0 Q I $E(DDBSA,1,11)="^DI(.84,920" D G PS^DDBR2 .N X .S X(1)="",X(2)=$$CTXT^DDBR($$EZBLD^DIALOG(7078.5),"",IOM) ;**RESTRICTED .W $$WS^DDBR1(.X),$C(7) .R X:5 .Q N DDBHA,DDBHAT S DDBHA=$NA(^TMP("DDWB",$J)),DDBHAT=0 I $D(^TMP("DDWB",$J))'>9 S ^TMP("DDWB",$J,1)="< No Text >",DDBHAT=1 D BROWSE^DDBR(DDBHA,"PNH","View Paste Buffer",$G(DDBHELPS),"",IOTM-1,IOBM+1) K:DDBHAT ^TMP("DDWB",$J) W @IOSTBM D PSR^DDBR0(1) Q ; SWITCH ; Switching Restricted while in View N X S X(1)="",X(2)=$$CTXT^DDBR($$EZBLD^DIALOG(7078.6),"",IOM) ;**RESTRICTED W $$WS^DDBR1(.X),$C(7) R X:5 G PS^DDBR2 ; OUT D PSR^DDBR0() Q ; WS(X) S DX=0,DY=$P(DDBSY,";",3)-3 X IOXY W $P(DDGLGRA,DDGLDEL) W $TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3)) W $P(DDGLGRA,DDGLDEL,2) W !,$P(DDGLCLR,DDGLDEL),$G(X(1)) W !,$P(DDGLCLR,DDGLDEL),$G(X(2)) W !,$P(DDGLCLR,DDGLDEL),$G(X(3)) S DY=$P(DDBSY,";",3),DX=$L($G(X(2)))+2 X IOXY Q "" DDBRZIS^INT^1^^0 DDBRZIS ;SFISC/DCL-BROWSER DEVICE UTILITIES ;9MAY2008 ;;22.0;VA FileMan;**1032**;Mar 30, 1999 OPEN ; ;DDBRZIS AND DDBDMSG ARE KILLED IN POST S DDBRZIS=1,DDBDMSG=$G(DDBDMSG) U IO(0) I $G(DDBDMSG)="" D Q:DDBDMSG="$$DTOUT$$" .N DIR,X,Y .S DIR(0)="FUO^0:78",DIR("A")="BROWSER TITLE (optional)" .S DIR("B")="VA FileMan Browser" .S DIR("?")="Enter any free text, which will appear in the Title Bar" .D ^DIR .I $G(DTOUT) S DDBDMSG="$$DTOUT$$" K DTOUT,DUOUT,DIRUT,DIROUT Q .S DDBDMSG=$S(Y="":DDBDMSG,1:Y) .Q W !,"...one moment..." U IO Q:DDBDMSG]"" I $G(DHD)="W """" D ^DIDH" S DDBDMSG="DATA DICTIONARY" Q S DDBDMSG="VA FileMan Browser" Q ; CLOSE ; Q:$G(DDBDMSG)="$$DTOUT$$" S DDBRZIS=$G(DDBRZIS,1) N C,CHAR,DDBROS,EOF,X K ^TMP("DDB",$J) S DDBROS=^%ZOSF("OS"),EOF="EOF-End Of File" S CHAR="" F I=1:1:31 S CHAR=CHAR_$C(I) U IO W !,EOF,! S DDBRZIS("REWIND")=$$REWIND^%ZIS(IO,IOT,IOPAR) I 'DDBRZIS("REWIND") S DDBRZIS=0 U IO(0) W $C(7),!!?5,"<< UNABLE TO REWIND FILE>>",! H 3 Q U IO S C=0 F R X:2 Q:X="EOF-End Of File" D .S X=$TR(X,CHAR) .S:X']"" X=" " .S C=C+1,^TMP("DDB",$J,C)=$E(X,1,255) Q IHS I C=1,^TMP("DDB",$J,C)=" " S ^TMP("DDB",$J,2)="BROWSER: No display data sent" Q ; POST ; I $G(DDBDMSG)="$$DTOUT$$" K DDBDMSG,DDBRZIS W $C(7) Q I $G(DDBRZIS) D BROWSE^DDBR("^TMP(""DDB"",$J)","NR",$G(DDBDMSG)) K DDBRZIS,DDBDMSG Q ; DEVICE(MSG) ;TEST IF BROWSER IS BEING INVOKED VIA DEVICE HANDLER ;EXTRINSIC FUNCTION I $D(DDBRZIS)#2,$G(MSG)]"" S DDBDMSG=MSG Q 1 Q 0 ; MSG(TXT) ;PASS TEXT FOR BROWSER TITLE WHEN BROWSER INVOKED VIA DEVICE HANDLER ;PROCEDURE CALL S DDBDMSG=$G(TXT) Q STR(X) ; Remove windows N I,Y I $L(X,"|")'>2 Q X I X["|WRAP|"!(X["| NO WRAP|")!(X["|NOWRAP|") S Y="" F I=1:1:$L(X,"|") S:(I#2) Y=Y_$P(X,"|",I) Q $S(X'["|":X,1:$G(Y)) DDFIX^INT^1^60300,29508^0 DDFIX ;SFCIOFO/S0/MKO VARIOUS DD AND DIC FIXES ;9:17 AM 15 Mar 1999 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; FIXPT ; ==> Fix Bad "PT" Nodes <== ; N EP,ESC I '$D(XPDNM) S EP="PT" D DEVICE I $D(ESC) G EXIT DEQPT N DICFILE,DDFILE,DDFIELD,PGLEN,PG,RPTDT,X U IO D RPTDT S PGLEN=IOSL-5,PG=0 I '$D(XPDNM) D PTHDR ; Loop thru DIC(, S DICFILE=1.99999 F S DICFILE=$O(^DIC(DICFILE)) Q:DICFILE'>1.99999!$D(ESC) D . ; Loop thru DD(DICFILE,0,"PT", . S DDFILE=1.99999 . F S DDFILE=$O(^DD(DICFILE,0,"PT",DDFILE)) Q:DDFILE'>1.99999!$D(ESC) D .. I $D(^DD(DDFILE,0))#2 D Q ; File Exists ... ; Check Fields Exists ... S DDFIELD=0 ... F S DDFIELD=$O(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) Q:'DDFIELD!$D(ESC) D .... I $D(^DD(DDFILE,DDFIELD,0))#2 D Q ; Field is still in DD ..... I ($P(^(0),U,2)'["P")&($P(^(0),U,2)'["V") D Q ; Field Still A Pointer? ...... S X="*File: "_DDFILE_" Field: "_DDFIELD_" is Not a Pointer Type." D RPTOUT ...... S X=" Deleting ""PT"" node: "_$NA(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) D RPTOUT,K1 Q ..... I $P(^(0),U,2)["P",+$P($P(^(0),U,2),"P",2)'=DICFILE D Q ; Field Still Point To Same File? ...... S X="*File: "_DDFILE_" Field: "_DDFIELD_" Does Not Point To File: "_DICFILE_"." D RPTOUT ...... S X=" Deleting ""PT"" Node: "_$NA(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) D RPTOUT,K1 Q .... ; **Field No Longer Exists .... S X="*Field: "_DDFIELD_" in File: "_DDFILE_" does Not Exist." D RPTOUT .... S X=" Deleting ""PT"" node: "_$NA(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) D RPTOUT,K1 Q .. ; **File No Longer Exists .. S X="*File: "_DDFILE_" Does Not Exist." D RPTOUT .. S X=" Deleting ""PT"" node: "_$NA(^DD(DICFILE,0,"PT",DDFILE)) D RPTOUT .. K ^DD(DICFILE,0,"PT",DDFILE) G EXIT ; GoTo Common Exit K1 ; Kill at Field Level K ^DD(DICFILE,0,"PT",DDFILE,DDFIELD) Q PTHDR ; Fix "PT" nodes Report Header I $E(IOST,1,2)="C-" D Q:$D(ESC) . I PG D PAUSE Q:$D(ESC) . W @IOF I PG W @IOF S PG=PG+1 W "Fix ""PT"" Nodes Report "_RPTDT,?(IOM-10),"Page: "_PG,! N X S X="",$P(X,"-",(IOM-1))="" W X,! Q ; FIXNM ; ==> Fix Duplicate 'NM' Nodes <== ; From patch DI*21*50, routine DIPR50 ; N EP,ESC I '$D(XPDNM) S EP="NM" D DEVICE I $D(ESC) G EXIT DEQNM N DDFILE,DDNAME,DDNEW,PGLEN,PG,RPTDT,X U IO D RPTDT S PGLEN=IOSL-5,PG=0 I '$D(XPDNM) D NMHDR S DDFILE=1.99999 F S DDFILE=$O(^DD(DDFILE)) Q:'DDFILE!$D(ESC) D . ; Check and repair duplicate "NM" nodes . S DDNAME=$O(^DD(DDFILE,0,"NM","")) Q:DDNAME="" . I $O(^DD(DDFILE,0,"NM",DDNAME))="" Q . S X="*File/Subfile: "_DDFILE_" has duplicate 'NM' nodes." . D RPTOUT . S DDNEW=$S($D(^DIC(DDFILE,0))#2:$P(^(0),U),1:$P(^DD(DDFILE,0)," SUB-FIELD")) . Q:DDNEW="" . K ^DD(DDFILE,0,"NM") . S ^DD(DDFILE,0,"NM",DDNEW)="" . S X=" ""NM"" node will be set to: "_DDNEW . D RPTOUT G EXIT ; GoTo Common Exit Point NMHDR ; Fix "NM" nodes Report Header I $E(IOST,1,2)="C-" D Q:$D(ESC) . I PG D PAUSE Q:$D(ESC) . W @IOF I PG W @IOF S PG=PG+1 W "Fix Duplicate ""NM"" Nodes Report "_RPTDT,?(IOM-10),"Page: "_PG,! N X S X="",$P(X,"-",(IOM-1))="" W X,! Q ; FIXAG ; ==> Application Group Multiple Bad Xrefs <== ; From patch DI*21*58, routine DIPR58 ; N EP,ESC I '$D(XPDNM) S EP="AG" D DEVICE I $D(ESC) G EXIT DEQAG N DDAGPKG,DDFILE,IEN,PGLEN,PG,RPTDT,X U IO D RPTDT S PGLEN=IOSL-5,PG=0 I '$D(XPDNM) D AGHDR S DDFILE=1.99999 F S DDFILE=$O(^DIC(DDFILE)) Q:DDFILE<1.99999 D . I '$D(^DIC(DDFILE,"%")) Q ; No App. Group Multiple . S DDAGPKG="" . F S DDAGPKG=$O(^DIC(DDFILE,"%","B",DDAGPKG)) Q:DDAGPKG="" D .. S IEN=0 .. F S IEN=$O(^DIC(DDFILE,"%","B",DDAGPKG,IEN)) Q:'IEN D ... I $P($G(^DIC(DDFILE,"%",IEN,0)),U)=DDAGPKG Q ... S X="Deleting App. Group "_DDAGPKG_" ""B"" xref: "_$NA(^DIC(DDFILE,"%","B",DDAGPKG,IEN)) ... D RPTOUT ... K ^DIC(DDFILE,"%","B",DDAGPKG,IEN) AC ; Loop Thru "AC" xref and Remove Any Entries That Point to ; Files That Do Not Exist S DDAGPKG="" F S DDAGPKG=$O(^DIC("AC",DDAGPKG)) Q:DDAGPKG="" D . S DDFILE=1.99999 . F S DDFILE=$O(^DIC("AC",DDAGPKG,DDFILE)) Q:DDFILE<1.99999 D .. I $D(^DIC(DDFILE,0))[0 D Q ... S X="Deleting ""AC"" xref: "_$NA(^DIC("AC",DDAGPKG,DDFILE)) ... D RPTOUT ... K ^DIC("AC",DDAGPKG,DDFILE) .. S IEN=0 .. F S IEN=$O(^DIC("AC",DDAGPKG,DDFILE,IEN)) Q:'IEN D ... I $P($G(^DIC(DDFILE,"%",IEN,0)),U)'=DDAGPKG D .... S X="Deleting ""AC"" xref: "_$NA(^DIC("AC",DDAGPKG,DDFILE,IEN)) .... D RPTOUT .... K ^DIC("AC",DDAGPKG,DDFILE,IEN) G EXIT ; GoTo Common Exit Point AGHDR ; Fix Application Group Xrefs Report Header I $E(IOST,1,2)="C-" D Q:$D(ESC) . I PG D PAUSE Q:$D(ESC) . W @IOF I PG W @IOF S PG=PG+1 W "Fix Application Group Xrefs Report "_RPTDT,?(IOM-10),"Page: "_PG,! N X S X="",$P(X,"-",(IOM-1))="" W X,! Q ; ; Common For All Entry Points ; DEVICE ; Output Device Selection S %ZIS="MQ" D ^%ZIS I POP S ESC=1 Q ;User Escaped Device Selection I $D(IO("Q")) D . S ZTDESC=$S(EP="PT":"FIX PT NODES",EP="NM":"FIX DUPLICATE 'NM' NODES",EP="AG":"FIX APPLICATION GROUP XREFS",1:"") . S ZTRTN=$S(EP="PT":"DEQPT",EP="NM":"DEQNM",EP="AG":"DEQAG",1:"")_"^DDFIX" . S ZTSAVE("EP")="" . D ^%ZTLOAD . I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),! . S ESC=1 . K ZTSK,ZTDESC,ZTRTN,ZTSAVE . D HOME^%ZIS Q RPTDT ; Get Report Date/Time N %,%H,X,Y S %H=$H D YX^%DTC S RPTDT=$P(Y,"@")_"@"_$E($P(Y,"@",2),1,5) Q RPTOUT ; Print Messages I $D(XPDNM) D MES^XPDUTL(X) Q ; KIDS install being used W X,! ; KIDS install not being used I $Y'>PGLEN Q I EP="PT" D PTHDR Q I EP="NM" D NMHDR Q I EP="AG" D AGHDR Q Q PAUSE ; End of Page Pause N DIR,Y S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) K DTOUT,DUOUT,DIRUT,DIROUT S ESC=1 Q Q EXIT ; Common Exit Point I $E(IOST,1,2)="P-" D ^%ZISC I $D(ZTQUEUED) S ZTREQ="@" K EP Q DDGF^INT^1^60300,29508^0 DDGF ;SFISC/MKO-FORM BUILDING TOOL ;7JAN2003 ;;22.0;VA FileMan;**1003**;Mar 30, 1999 ; ;Program-wide variables ; DDGFILE = File number^File name ; DDGFFM = Form number^Form name ; DDGFPG = Page number ; DDGFWID = Window id for given page ; DDGFWIDB = Window id for block displayer for a given page ; DDGFREF = Global reference where data is stored ; DDGFLIM = Boundaries within which cursor can be moved ; $Y1^$X1^$Y2^$X2 ; DDGFBV = If defined, we're in the block view page ; DDGFMSG = Indicates there's a message on the message line. ; N %,%W,%X,%Y,C,D,D0,DI,DIC,DIEQ,DIW,DIZ,DQ,I,X,Y,DIOVRD I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU D ^DDGF0 G:$G(DIERR) END^DDGF0 D SEL^DDGFFM G:$D(DDGFFM)[0 END^DDGF0 D ALL^DDGFASUB,^DDGF1,END^DDGF0 Q ; REFRESH ;Repaint all windows, status line D REPALL^DDGLIBW(),STATUS Q ; STATUS ;Paint status line N DX,DY,N,S K DDGFMSG S DY=IOSL-7,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL,3)_$TR($J("",IOM-1)," ","_") ; S DY=IOSL-6 X IOXY W "File: "_$P(DDGFFILE,U,2)_" (#"_$P(DDGFFILE,U)_")" I $D(DDGFBV)#2 S DX=46 X IOXY W "BLOCK VIEWER" W !,"Form: "_$P(DDGFFM,U,2)_" (#"_+DDGFFM_")" S N=$G(@DDGFREF@("F",+$G(DDGFPG))) W !,"Page: "_$S(N]"":$P(N,U,6)_" ("_$P(N,U,5)_")",1:""),!!! I $D(DDGFBV)#2 W $P(DDGLVID,DDGLDEL)_"V=Main Screen H=Help"_$P(DDGLVID,DDGLDEL,10) E W $P(DDGLVID,DDGLDEL)_"Q=Quit E=Exit S=Save V=Block Viewer H=Help"_$P(DDGLVID,DDGLDEL,10) Q ; MSG(M) ;Print message N DDGFDY,DDGFDX S DDGFDY=DY,DDGFDX=DX S:$D(M)[0 M="" S DY=IOSL-2,DX=0 X IOXY ; W $E(M,1,79)_$P(DDGLCLR,DDGLDEL) S:M]"" DDGFMSG=1 K:M="" DDGFMSG S DY=DDGFDY,DX=DDGFDX X IOXY Q ; RESET ;Reset terminal and cleanup S DDGFREF="^TMP(""DDGF"",$J)",DDGLREF="^TMP(""DDGL"",$J)" K DDSFILE,DDSPAGE,DDSPARM,DR G KILL^DDGF0 DDGF0^INT^1^60300,29508^0 DDGF0 ;SFISC/MKO-SETUP, CLEANUP ;07:54 PM 18 May 2002 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; D INIT^DDGLIB0() Q:$G(DIERR) D SET,GETKEY Q ; SET ;Setup variables D:$D(DT)[0 DT^DICRW S (DIOVRD,DDGFR)=1,DDGFREF="^TMP(""DDGF"",$J)",DDGFCHG=0 K @DDGFREF,DDGFFM Q ; END ;Clear screen, clean up variables I $D(DDGFFM)#2 D RECOMP KILL ; D:$G(DIERR) MSG^DIALOG("BW") X:$D(DDGLZOSF) DDGLZOSF("EON"),DDGLZOSF("TRMOFF") D KILL^DDGLIB0() K:$D(DDGFREF) @DDGFREF,DDGFREF K ^TMP("DDGFH",$J) K DDGF,DDGFBV,DDGFCHG,DDGFE,DDGFFILE,DDGFFM,DDGFLIM,DDGFMSG K DDGFPG,DDGFR,DDGFWID,DDGFWIDB K DDH Q ; RECOMP ;Recompile form N DDGFLIST S DDGFLIST=$NA(^TMP("DDGFOF",$J)) D MSG^DDGF("Recompiling ...") ; D GETBLKS(+DDGFFM,DDGFLIST) S DDSQUIET=1 D EN^DDSZ(DDGFFM) K DDSQUIET I $D(@DDGFLIST) D . N DDGFI . S DDGFI="" . F S DDGFI=$O(@DDGFLIST@(DDGFI)) Q:'DDGFI D EN^DDSZ(DDGFI) . K @DDGFLIST ; D MSG^DDGF("") S DX=0,DY=IOSL-1 X IOXY Q ; GETBLKS(F,L) ; ;Determine if any of the blocks loaded are ;used on other forms. ; L(Form#)="" Other forms that need recompiling ; N P,B S P=0 F S P=$O(@DDGFREF@("F",P)) Q:'P D . S B=0 . F S B=$O(@DDGFREF@("F",P,B)) Q:'B D:'$D(@L@("B",B)) .. S @L@("B",B)="" .. D OTHER(B,F,L) K @L@("B") Q ; OTHER(B,F,L) ; ;Return list L of forms other than F that use block B ; L(Form#)="" N F1 S F1="" F S F1=$O(^DIST(.403,"AB",B,F1)) Q:F1="" I F1'=F S @L@(F1)="" S F1="" F S F1=$O(^DIST(.403,"AC",B,F1)) Q:F1="" I F1'=F S @L@(F1)="" Q ; GETKEY ;Get key sequences and defaults N AU,AD,AR,AL,F1,F2,F3,F4,I,K,N,T S AU=$P(DDGLKEY,U,2) S AD=$P(DDGLKEY,U,3) S AR=$P(DDGLKEY,U,4) S AL=$P(DDGLKEY,U,5) S F1=$P(DDGLKEY,U,6) S F2=$P(DDGLKEY,U,7) S F3=$P(DDGLKEY,U,8) S F4=$P(DDGLKEY,U,9) ; F N="","S","D" D . S DDGF(N_"IN")="",DDGF(N_"OUT")="" . F I=1:1 S T=$P($T(@(N_"MAP")+I),";;",2,999) Q:T="" D .. S @("K="_$P(T,";",2)) .. I DDGF(N_"IN")'[(U_K) D ... S DDGF(N_"IN")=DDGF(N_"IN")_U_K ... S DDGF(N_"OUT")=DDGF(N_"OUT")_$P(T,";")_U . S DDGF(N_"IN")=DDGF(N_"IN")_U . S DDGF(N_"OUT")=$E(DDGF(N_"OUT"),1,$L(DDGF(N_"OUT"))-1) Q ; MAP ;Keys for main screen ;;LNU;AU; line up ;;LND;AD; line down ;;CHR;AR; char right ;;CHL;AL; char left ;;ELR;$C(9); element right ;;ELL;"Q"; element left ;;TBR;"S"; tab right ;;TBL;"A"; tab left ;;EXIT;F1_"E"; exit ;;QUIT;F1_"Q"; quit ;;ROWCOL;"R"; row/col indicator toggle ;;SCT;F1_AU; top of screen ;;SCB;F1_AD; bottom of screen ;;SCR;F1_AR; right edge of screen ;;SCL;F1_AL; left edge of screen ;;SAVE;F1_"S"; save changes ;;SELECT;" "; select an element ;;SELECT;$C(13); select an element ;;SELFILE;F1_1; select file ;;VIEW;F1_"V"; view toggle ;;EDIT;F3; edit caption or data length ;;FLDADD;F2_"F"; add a new field ;;BKADD;F2_"B"; add a new block ;;NXTPG;F1_F1_AD; go to next page ;;PRVPG;F1_F1_AU; go to previous page ;;CLSPG;F1_"C"; close popup page ;;PGSEL;F1_"P"; select another page ;;PGADD;F2_"P"; add a new page ;;PGEDIT;F4_"P"; edit page attributes ;;FMSEL;F1_"M"; select another form ;;FMADD;F2_"M"; add a new form ;;FMEDIT;F4_"M"; edit form attributes ;;HELP;F1_"H" ;; SMAP ;Keys for moving selected gadgets ;;LNU;AU; line up ;;LND;AD; line down ;;CHR;AR; char right ;;CHL;AL; char left ;;TBR;$C(9); tab right ;;TBR;"S"; " " ;;TBL;"Q"; tab left ;;TBL;"A"; " " ;;ROWCOL;"R"; row/col indicator toggle ;;SCT;F1_AU; top of screen ;;SCB;F1_AD; bottom of screen ;;SCR;F1_AR; right edge of screen ;;SCL;F1_AL; left edge of screen ;;SUBPG;F1_"D"; go into a multiples pop-up page ;;DESELECT;" "; deselect an element ;;DESELECT;$C(13); deselect an element ;;EDIT;F4; edit properties ;;REORDER;F1_"O"; reorder fields in block ;; DMAP ;Keys for changing data length ;;CHR;AR; char right ;;CHL;AL; char left ;;DONE;$C(13); done ;;DONE;" "; done ;;DONE;F3; done ;; DDGF1^INT^1^60300,29508^0 DDGF1 ;SFISC/MKO-MAIN SCREEN ;02:46 PM 12 Oct 1994 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. D RC($P(DDGFLIM,U),$P(DDGFLIM,U,2)) S DDGFE=0 F S Y=$$READ W:$T(@Y)="" $C(7) D:$D(DDGFMSG) MSG^DDGF() D:$T(@Y)]"" @Y Q:DDGFE Q ; LNU I DY>$P(DDGFLIM,U) D RC(DY-1,DX) Q LND I DY<$P(DDGFLIM,U,3) D RC(DY+1,DX) Q CHR I DX<$P(DDGFLIM,U,4) D RC(DY,DX+1) Q CHL I DX>$P(DDGFLIM,U,2) D RC(DY,DX-1) Q ; ELR N Y,X S Y=DY,X=DX S X=$O(@DDGFREF@("RC",DDGFWID,Y,X)) D:X="" . S Y=$O(@DDGFREF@("RC",DDGFWID,Y)) . S:Y="" Y=$O(@DDGFREF@("RC",DDGFWID,"")) . S:Y]"" X=$O(@DDGFREF@("RC",DDGFWID,Y,"")) D:X]"" RC(Y,X) Q ELL N Y,X S Y=DY,X=DX S X=$O(@DDGFREF@("RC",DDGFWID,Y,X),-1) D:X="" . S Y=$O(@DDGFREF@("RC",DDGFWID,Y),-1) . S:Y="" Y=$O(@DDGFREF@("RC",DDGFWID,""),-1) . S:Y]"" X=$O(@DDGFREF@("RC",DDGFWID,Y,""),-1) D:X]"" RC(Y,X) Q ; TBR I DX<$P(DDGFLIM,U,4) D . D RC(DY,$S(DX+5'<$P(DDGFLIM,U,4):$P(DDGFLIM,U,4),1:DX+5)) E I DY<$P(DDGFLIM,U,3) D RC(DY+1,$P(DDGFLIM,U,2)) Q TBL I DX>$P(DDGFLIM,U,2) D . D RC(DY,$S(DX-5'>$P(DDGFLIM,U,2):$P(DDGFLIM,U,2),1:DX-5)) E I DY>$P(DDGFLIM,U) D RC(DY-1,$P(DDGFLIM,U,4)) Q ; SCT I DY>$P(DDGFLIM,U) D RC($P(DDGFLIM,U),DX) Q SCB I DY<$P(DDGFLIM,U,3) D RC($P(DDGFLIM,U,3),DX) Q SCR I DX<$P(DDGFLIM,U,4) D RC(DY,$P(DDGFLIM,U,4)) Q SCL I DX>$P(DDGFLIM,U,2) D RC(DY,$P(DDGFLIM,U,2)) Q ; SAVE ;Save data from DDGFREF I 'DDGFPG D ERR(110) Q G SAVE^DDGFSV ; SELECT ;Select an item I 'DDGFPG D ERR(110) Q G SELECT^DDGFEL ; EDIT ;Edit a caption or data length I 'DDGFPG D ERR(110) Q G EDIT^DDGFEL ; FLDADD ;Add a new field to the form I 'DDGFPG D ERR(110) Q G ADD^DDGFFLDA ; VIEW ;Go to block viewer I 'DDGFPG D ERR(110) Q I $O(@DDGFREF@("F",DDGFPG,""))="" D ERR(120) Q G ^DDGF3 ; BKADD ;Add a new block I 'DDGFPG D ERR(110) Q G ADD^DDGFBK ; HBKADD ;Add a header block I 'DDGFPG D ERR(110) Q G ADD^DDGFHBK ; NXTPG ;Go to next page I 'DDGFPG D ERR(110) Q D NXTPRV^DDGFPG(1) Q ; PRVPG ;Go to previous page I 'DDGFPG D ERR(110) Q D NXTPRV^DDGFPG(-1) Q ; CLSPG ;Close pop-up page G CLSPG^DDGFPG ; PGSEL ;Select a new page I 'DDGFPG D ERR(110) Q G PGSEL^DDGFPG ; PGADD ;Add a new page to the form G ADD^DDGFPG ; PGEDIT ;Edit attributes of a page I 'DDGFPG D ERR(110) Q G EDIT^DDGFPG ; FMSEL ;Select another form G SEL^DDGFFM ; FMADD ;Add a new form G ADD^DDGFFM ; FMEDIT ;Edit the form G EDIT^DDGFFM ; HELP ;Invoke help screens G HLP^DDGFH ; TO ;Time-out W $C(7) G QUIT ; QUIT ;Exit from form designer I DDGLSCR>1 G CLSPG^DDGFPG S DDGFE=1 Q EXIT ;Save and exit I DDGLSCR>1 G CLSPG^DDGFPG S DDGFE=1 G SAVE^DDGFSV ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N DDGFS I DDGFR D . S DY=IOSL-6,DX=IOM-9,DDGFS="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W DDGFS_$J("",7-$L(DDGFS)) S DY=DDGFY,DX=DDGFX X IOXY Q ; READ() N S,Y F R *Y:DTIME D C Q:Y'=-1 Q Y ; C I Y<0 S Y="TO" Q S S="" C1 S S=S_$C(Y) I DDGF("IN")'[(U_S) D I Y=-1 W $C(7) Q . I $C(Y)'?1L S Y=-1 Q . S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDGF("IN")'[(U_S_U) Y=-1 ; I DDGF("IN")[(U_S_U),S'=$C(27) S Y=$P(DDGF("OUT"),U,$L($P(DDGF("IN"),U_S_U),U)) Q R *Y:5 G:Y'=-1 C1 W $C(7) Q ; ERR(X) ; D MSG^DDGF($C(7)_$P($T(@X),";;",2,999)) H 3 D MSG^DDGF() Q 110 ;;There are no pages on this form. Use PF2-P to add a page. 120 ;;There are no blocks on this page. Use PF2-B to add a block. DDGF2^INT^1^60300,29508^0 DDGF2 ;SFISC/MKO-ACTIONS FOR SELECTED FIELDS ;02:48 PM 12 Oct 1994 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ;Input: ; B = internal block number ; F = internal field order ; T = type of element ("C" = caption, "D" = data) ; C = caption ; C1 = $Y of caption ; C2 = $X of caption ; D = data representation (underlines) ; D1 = $Y of data ; D2 = $X of data ; L = length of data ; P1 = page $Y ; P2 = page $X N DDGFE S DDGFE=0,DDGFLSV=DDGFLIM S DDGFLIM=$P(@DDGFREF@("F",DDGFPG,B),U,1,2)_U_$P(DDGFLIM,U,3,4) ; D PAINTS S DDGFE=0 F S Y=$$READ W:$T(@Y)="" $C(7) D:$T(@Y)]"" @Y Q:DDGFE D END D:$G(DDGFSUBP) SUBPG1^DDGFPG Q ; END ;Redraw the field S DDGFLIM=DDGFLSV K DDGFLSV Q:$D(^DIST(.404,B,40,F,0))[0 ; S C3=C2+$L(C)-1 I T="C",C]"" D . D WRITE^DDGLIBW(DDGFWID,C,C1-P1,C2-P2) . S @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")="" ; I $D(D) D . S D3=D2+L-1 . D WRITE^DDGLIBW(DDGFWID,D,D1-P1,D2-P2) . S @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")="" ; S @DDGFREF@("F",DDGFPG,B,F)=C1_U_C2_U_C3_U_C_U_$S($D(D):D1_U_D2_U_D3_U_L,1:"^^^")_U_1,DDGFCHG=1 X IOXY Q ; TO ;Time-out W $C(7) G DESELECT ; DESELECT ; S DDGFE=1 Q ; LNU I T="C" Q:C1'>$P(DDGFLIM,U) I $D(D),D1'>$P(DDGFLIM,U) Q D REDRAW S:T="C" C1=C1-1 S:$D(D) D1=D1-1 S DY=DY-1 D PAINTS Q LND I T="C" Q:C1'<$P(DDGFLIM,U,3) I $D(D),D1'<$P(DDGFLIM,U,3) Q D REDRAW S:T="C" C1=C1+1 S:$D(D) D1=D1+1 S DY=DY+1 D PAINTS Q CHR I T="C" Q:C2+$L(C)>$P(DDGFLIM,U,4) I $D(D),D2+L>$P(DDGFLIM,U,4) Q D REDRAW S:T="C" C2=C2+1 S:$D(D) D2=D2+1 S DX=DX+1 D PAINTS Q CHL I T="C" Q:C2'>$P(DDGFLIM,U,2) I $D(D),D2'>$P(DDGFLIM,U,2) Q D REDRAW S:T="C" C2=C2-1 S:$D(D) D2=D2-1 S DX=DX-1 D PAINTS Q TBR N X I T="C" Q:C2+$L(C)>$P(DDGFLIM,U,4) I $D(D),D2+L>$P(DDGFLIM,U,4) Q D REDRAW I T="C" D . S X=$$MIN(5,$P(DDGFLIM,U,4)-(C2+$L(C)),$S($D(D):$P(DDGFLIM,U,4)-(D2+L)+1,1:"")) . S C2=C2+X E S X=$$MIN(5,$P(DDGFLIM,U,4)-(D2+L)+1) S:$D(D) D2=D2+X S DX=DX+X D PAINTS Q TBL N X I T="C" Q:C2'>$P(DDGFLIM,U,2) I $D(D),D2'>$P(DDGFLIM,U,2) Q D REDRAW I T="C" D . S X=$$MIN(5,C2-$P(DDGFLIM,U,2),$S($D(D):D2-$P(DDGFLIM,U,2),1:"")) . S C2=C2-X E S X=$$MIN(5,D2-$P(DDGFLIM,U,2)) S:$D(D) D2=D2-X S DX=DX-X D PAINTS Q SCT N Y I T="C" Q:C1'>$P(DDGFLIM,U) I $D(D),D1'>$P(DDGFLIM,U) Q D REDRAW I T="C" S Y=$S('$D(D):C1,C1D1:C1,1:D1),C1=C1+Y E S Y=$P(DDGFLIM,U,3)-D1 S:$D(D) D1=D1+Y S DY=DY+Y D PAINTS Q SCR N X I T="C" Q:C2+$L(C)>$P(DDGFLIM,U,4) I $D(D),D2+L>$P(DDGFLIM,U,4) Q D REDRAW I T="C" D . S X=$P(DDGFLIM,U,4)-$S('$D(D):C2+$L(C),C2+$L(C)>(D2+L):C2+$L(C),1:D2+L)+1 . S C2=C2+X E S X=$P(DDGFLIM,U,4)-(D2+L)+1 S:$D(D) D2=D2+X S DX=DX+X D PAINTS Q SCL N X I T="C" Q:C2'>$P(DDGFLIM,U,2) I $D(D),D2'>$P(DDGFLIM,U,2) Q D REDRAW I T="C" S X=$S('$D(D):C2,C2$P(DDGFLIM,U) D RC(DY-1,DX) Q LND I DY<$P(DDGFLIM,U,3) D RC(DY+1,DX) Q CHR I DX<$P(DDGFLIM,U,4) D RC(DY,DX+1) Q CHL I DX>$P(DDGFLIM,U,2) D RC(DY,DX-1) Q ELR N Y,X S Y=DY,X=DX F D Q:Y=""!(X]"") . S X=$O(@DDGFREF@("BKRC",DDGFWIDB,Y,X)) . S:X="" Y=$O(@DDGFREF@("BKRC",DDGFWIDB,Y)) D:X]"" RC(Y,X) Q ELL N Y,X S Y=DY,X=DX F D Q:Y=""!(X]"") . S X=$O(@DDGFREF@("BKRC",DDGFWIDB,Y,X),-1) . S:X="" Y=$O(@DDGFREF@("BKRC",DDGFWIDB,Y),-1) D:X]"" RC(Y,X) Q TBR I DX<$P(DDGFLIM,U,4) D . D RC(DY,$S(DX+5'<$P(DDGFLIM,U,4):$P(DDGFLIM,U,4),1:DX+5)) E I DY<$P(DDGFLIM,U,3) D RC(DY+1,$P(DDGFLIM,U,2)) Q TBL I DX>$P(DDGFLIM,U,2) D . D RC(DY,$S(DX-5'>$P(DDGFLIM,U,2):$P(DDGFLIM,U,2),1:DX-5)) E I DY>$P(DDGFLIM,U) D RC(DY-1,$P(DDGFLIM,U,4)) Q ; SCT I DY>$P(DDGFLIM,U) D RC($P(DDGFLIM,U),DX) Q SCB I DY<$P(DDGFLIM,U,3) D RC($P(DDGFLIM,U,3),DX) Q SCR I DX<$P(DDGFLIM,U,4) D RC(DY,$P(DDGFLIM,U,4)) Q SCL I DX>$P(DDGFLIM,U,2) D RC(DY,$P(DDGFLIM,U,2)) Q SELECT ; Q:'$D(@DDGFREF@("BKRC",DDGFWIDB,DY)) G SELECT^DDGFBSEL ; SAVE ;Save data G SAVE^DDGFSV ; BKADD ;Add a new block G ADD^DDGFBK ; HBKADD ;Add a header block G ADD^DDGFHBK ; HELP ;Invoke help screens D ^DDGFH,REFRESH^DDGF,RC(DY,DX) Q ; TO W $C(7) QUIT ; EXIT ; VIEW S DDGFE=1 Q CLEANUP ; S DDGFDY=DY,DDGFDX=DX D CLOSE^DDGLIBW(DDGFWIDB,1) I $D(DDGFORIG) D . N A . S A=$$AREA^DDGLIBW(DDGFWID) . D DESTROY^DDGLIBW(DDGFWID,1) . D CREATE^DDGLIBW(DDGFWID,A,$P(@DDGFREF@("F",DDGFPG),U,3)]"") . D BLK^DDGFUPDB(.DDGFORIG) E D OPEN^DDGLIBW(DDGFWID) S DY=IOSL-6,DX=46 X IOXY W $J("",13) S DY=IOSL-1,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)_$P(DDGLVID,DDGLDEL)_"Q=Quit E=Exit S=Save V=Block Viewer H=Help"_$P(DDGLVID,DDGLDEL,10) D RC(DDGFDY,DDGFDX) K DDGFDY,DDGFDX,DDGFBV,DDGFEBV,DDGFORIG Q ; PAINT ;Paint block displayer window N B,C,S,DY,DX D CLOSE^DDGLIBW(DDGFWID,1) S DY=IOSL-6,DX=46 X IOXY W "BLOCK VIEWER" S DY=IOSL-1,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)_$P(DDGLVID,DDGLDEL)_"V=Main Screen H=Help"_$P(DDGLVID,DDGLDEL,10) I $$EXIST^DDGLIBW(DDGFWIDB) D FOCUS^DDGLIBW(DDGFWIDB) Q D CREATE^DDGLIBW(DDGFWIDB,$P(DDGFLIM,U,1,2)_U_($P(DDGFLIM,U,3)-$P(DDGFLIM,U,1)+1)_U_($P(DDGFLIM,U,4)-$P(DDGFLIM,U,2)+1),$P(@DDGFREF@("F",DDGFPG),U,3)]"") S B="" F S B=$O(@DDGFREF@("F",DDGFPG,B)) Q:B="" D . S C=@DDGFREF@("F",DDGFPG,B) . S S=$P(C,U,4) . S:$P(C,U,3)'$P(DDGFLIM,U)!DDGFHDR D REDRAW S C1=C1-1,DY=DY-1 D PAINTS Q LND Q:C1'<$P(DDGFLIM,U,3)!DDGFHDR D REDRAW S C1=C1+1,DY=DY+1 D PAINTS Q CHR Q:C2'<$P(DDGFLIM,U,4)!DDGFHDR D REDRAW S C2=C2+1,DX=DX+1 D PAINTS Q CHL Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR D REDRAW S C2=C2-1,DX=DX-1 D PAINTS Q TBR N X Q:C2+$L(C)>$P(DDGFLIM,U,4)!DDGFHDR D REDRAW S X=$$MIN(5,$P(DDGFLIM,U,4)-C2-$L(C)+1) S C2=C2+X,DX=DX+X D PAINTS Q TBL N X Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR D REDRAW S X=$$MIN(5,C2-$P(DDGFLIM,U,2)) S C2=C2-X,DX=DX-X D PAINTS Q SCT Q:C1'>$P(DDGFLIM,U)!DDGFHDR D REDRAW S (C1,DY)=$P(DDGFLIM,U) D PAINTS Q SCB Q:C1'<$P(DDGFLIM,U,3)!DDGFHDR D REDRAW S (C1,DY)=$P(DDGFLIM,U,3) D PAINTS Q SCR N X Q:C2+$L(C)>$P(DDGFLIM,U,4)!DDGFHDR D REDRAW S X=$P(DDGFLIM,U,4)-C2-$L(C)+1 S C2=C2+X,DX=DX+X D PAINTS Q SCL N X Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR D REDRAW S X=C2-$P(DDGFLIM,U,2) S C2=C2-X,DX=DX-X D PAINTS Q ; EDIT ;Edit block parameters G:'$G(DDGFHDR) EDIT^DDGFBK G EDIT^DDGFHBK ; REORDER ;Reorder fields on block D EN^DDGFORD(B) Q ; TO ;Time-out W $C(7) G DESELECT ; DESELECT ; S DDGFE=1 Q ; CLEANUP ; I '$G(DDGFBDEL) D . S C3=C2+$L(C)-1 . S @DDGFREF@("F",DDGFPG,B)=C1_U_C2_U_C3_U_C_U_1,DDGFCHG=1 . S @DDGFREF@("BKRC",DDGFWIDB,C1,C2,C3,B)=$S($G(DDGFHDR):"H",1:"") ; I '$G(DDGFEBV),'$G(DDGFBDEL) D . D WRITE^DDGLIBW(DDGFWIDB,C,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2)) . X IOXY K DDGFHDR,DDGFBDEL Q ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N S I DDGFR D . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W S_$J("",7-$L(S)) S DY=DDGFY,DX=DDGFX X IOXY Q ; REDRAW ; D REPAINT^DDGLIBW(DDGFWIDB,(C1-$P(DDGFLIM,U))_U_(C2-$P(DDGFLIM,U,2))_U_1_U_$$MIN($L(C),$P(DDGFLIM,U,4)-C2+1)) Q ; PAINTS ; N Y,X S Y=DY,X=DX S DY=C1,DX=C2 X IOXY W $P(DDGLVID,DDGLDEL,6)_$E(C,1,$$MIN($L(C),$P(DDGFLIM,U,4)-C2+1))_$P(DDGLVID,DDGLDEL,10) D RC(Y,X) Q ; MIN(X,Y,Z) ;Return the minimum of two or three numbers N A S A=$S(X$P(DDGFLIM,U) D MV(DY-1,DX) Q LND Q:DY'<$P(DDGFLIM,U,3) D MV(DY+1,DX) Q CHR Q:DX'<$P(DDGFLIM,U,4) D MV(DY,DX+1) Q CHL Q:DX'>$P(DDGFLIM,U,2) D MV(DY,DX-1) Q TBR Q:DX'<$P(DDGFLIM,U,4) D MV(DY,DX+$$MIN(5,$P(DDGFLIM,U,4)-DX)) Q TBL Q:DX'>$P(DDGFLIM,U,2) D MV(DY,DX-$$MIN(5,DX-$P(DDGFLIM,U,2))) Q SCT Q:DY'>$P(DDGFLIM,U) D MV($P(DDGFLIM,U),DX) Q SCB Q:DY'<$P(DDGFLIM,U,3) D MV($P(DDGFLIM,U,3),DX) Q SCR Q:DX'<$P(DDGFLIM,U,4) D MV(DY,$P(DDGFLIM,U,4)) Q SCL Q:DX'>$P(DDGFLIM,U,2) D MV(DY,$P(DDGFLIM,U,2)) Q ; MV(DDGFY,DDGFX) ; I T="PTOP" D . F DDGFC=P1_U_P2,P1_U_P4,P3_U_P2,P3_U_P4 D REPALL^DDGLIBW(DDGFC_"^1^1") . S P1=P1+DDGFY-DY,P2=P2+DDGFX-DX,P3=P3+DDGFY-DY,P4=P4+DDGFX-DX ; I T="PBRC" D . D:DDGFX'=DX REPALL^DDGLIBW(P1_U_P4_"^1^1") . D:DDGFY'=DY REPALL^DDGLIBW(P3_U_P2_"^1^1") . D REPALL^DDGLIBW(P3_U_P4_"^1^1") . S P3=P3+DDGFY-DY,P4=P4+DDGFX-DX ; D CORNER() S DY=DDGFY,DX=DDGFX K DDGFC Q ; CORNER(N) ;Draw corners of box ;In: P1,P2,P3,P4,T; if N:normal video N DY,DX S DY=P1,DX=P2 X IOXY W $P(DDGLGRA,DDGLDEL)_$S($G(N):"",1:$P(DDGLVID,DDGLDEL,6))_$P(DDGLGRA,DDGLDEL,5) S DY=P1,DX=P4 X IOXY W $P(DDGLGRA,DDGLDEL,6) S DY=P3,DX=P2 X IOXY W $P(DDGLGRA,DDGLDEL,7) S DX=P4 X IOXY W $P(DDGLGRA,DDGLDEL,8)_$S($G(N):"",1:$P(DDGLVID,DDGLDEL,10))_$P(DDGLGRA,DDGLDEL,2) Q ; MIN(X,Y,Z) ;Return the minimum of two or three numbers N A S A=$S(X0 @DDGFREF@("RC",DDGFWID,$P(N,U,5),$P(N,U,6),$P(N,U,7),B) K @DDGFREF@("F",DDGFPG,B) ; ;If no blocks on page, set DDGFEBV to exit Block Viewer ;DDGFBDEL indicates block name should not be painted I $G(DDGFBV) D:'$G(E) . I '$P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2),'$O(^(40,0)) S DDGFEBV=1 . S DDGFBDEL=1 E D PG^DDGFLOAD(+DDGFFM,+DDGFPG,1,1) ; ;If used on no other forms, ask whether to delete from block file I '$O(^DIST(.403,"AB",B,"")),'$O(^DIST(.403,"AC",B,"")) D . K DDGFANS S DDGFBK=B . D DDS(.404,"[DDGF BLOCK DELETE]") . I $G(DDGFANS) S DIK="^DIST(.404,",DA=DDGFBK D ^DIK K DIK,DA . K DDGFANS,DDGFBK Q ; DDS(DDSFILE,DR,DA,DDSPAGE) ; ;Call DDS S DDSPARM="KTW" D ^DDS K DDSPARM Q ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N S I DDGFR D . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W S_$J("",7-$L(S)) S DY=DDGFY,DX=DDGFX X IOXY Q DDGFBSEL^INT^1^60300,29508^0 DDGFBSEL ;SFISC/MKO-SELECT BLOCK ;07:50 AM 23 Aug 1993 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ;Sets: ; DDGFORIG(B) = original $Y^original $X for all blocks that were ; selected, since they were potentially moved SELECT ; N B,C,C1,C2,C3 N B1,X1,X2 ; ;Which element is the cursor on? ;Set B=Block S X1="" K B F S X1=$O(@DDGFREF@("BKRC",DDGFWIDB,DY,X1)) Q:X1=""!(DXX2 .. S B=$O(@DDGFREF@("BKRC",DDGFWIDB,DY,X1,X2,"")) .. I @DDGFREF@("BKRC",DDGFWIDB,DY,X1,X2,B)="H",$O(^(B)) S B=$O(^(B)) Q:'$G(B) ; ;Get caption and coordinates S B1=$G(@DDGFREF@("F",DDGFPG,B)) Q:B1="" S C1=$P(B1,U),C2=$P(B1,U,2),C3=$P(B1,U,3),C=$P(B1,U,4) ; S:@DDGFREF@("BKRC",DDGFWIDB,C1,C2,C3,B)="H" DDGFHDR=1 D COVER ; K B1,X1,X2 G ^DDGF4 ; COVER ; N H,O,L ;Clear and/or kill portions of DDGFREF K @DDGFREF@("BKRC",DDGFWIDB,C1,C2,C3,B) ; ;Remember original block coordinates S:$D(DDGFORIG(B))[0 DDGFORIG(B)=C1_U_C2 ; ;Look for covered (hidden) fields ;Set H(B) - array of hidden fields S X1="" F S X1=$O(@DDGFREF@("BKRC",DDGFWIDB,C1,X1)) Q:X1="" D . S X2="" . F S X2=$O(@DDGFREF@("BKRC",DDGFWIDB,C1,X1,X2)) Q:X2="" D .. S H=$O(@DDGFREF@("BKRC",DDGFWIDB,C1,X1,X2,"")) .. I H]"",$D(H(H))[0,$$OVERLAP(C2,C3,X1,X2) S H(H)="" ; ;Clear in buffer area occupied by element(s) selected ;If block on the page border, redraw the lines S L=$J("",$L(C)-$S(C3>$P(DDGFLIM,U,4):C3-$P(DDGFLIM,U,4),1:0)) D WRITE^DDGLIBW(DDGFWIDB,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1) ; I $P(@DDGFREF@("F",DDGFPG),U,3) D . I C1=$P(DDGFLIM,U)!(C1=$P(DDGFLIM,U,3)) D .. S L=$TR(L," ",$P(DDGLGRA,DDGLDEL,3)) .. S:C2=$P(DDGFLIM,U,2) $E(L)=$P(DDGLGRA,DDGLDEL,$S(C1=$P(DDGFLIM,U):5,1:7)) .. S:C3'<$P(DDGFLIM,U,4) $E(L,$L(L))=$P(DDGLGRA,DDGLDE,$S(C1=$P(DDGFLIM,U):6,1:8)) .. D WRITE^DDGLIBW(DDGFWIDB,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1) . E I C2=$P(DDGFLIM,U,2) D .. D WRITE^DDGLIBW(DDGFWIDB,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1) . E I C3'<$P(DDGFLIM,U,4) D .. D WRITE^DDGLIBW(DDGFWIDB,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),$P(DDGFLIM,U,4)-$P(DDGFLIM,U,2),"G",1) ; ;Write to buffer the overlapped blocks(s) I $D(H)>1 S H="" F S H=$O(H(H)) Q:H="" D . S B1=$G(@DDGFREF@("F",DDGFPG,H)) Q:B1="" . D WRITE^DDGLIBW(DDGFWIDB,$P(B1,U,4),$P(B1,U)-$P(DDGFLIM,U),$P(B1,U,2)-$P(DDGFLIM,U,2),"",1) Q ; OVERLAP(A1,A2,B1,B2) ;Does line with X-coords A1,A2 overlap B1,B2 N T I A1B2)!(A2'B2)) DDGFEL^INT^1^60300,29508^0 DDGFEL ;SFISC/MKO-SELECT OR EDIT ELEMENT ;07:25 AM 7 Aug 1995 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; SELECT ;Select an element N B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2 D GETELEM(DY,DX) Q:$G(F)="" ; I F="P" G ^DDGFAPC ; ;Clear and/or kill portions of DDGFREF S:T="D" $P(@DDGFREF@("F",DDGFPG,B,F),U,5,8)="" K:T="C" @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C"),@DDGFREF@("F",DDGFPG,B,F) K:$D(D) @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D") ; D COVER G ^DDGF2 ; EDIT ;Edit a caption or data length N B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2,X,Y D GETELEM(DY,DX) Q:"P"[$G(F) ; S DDGFCHG=1 I T="C" D . K D,D1,D2,D3,L . S $P(@DDGFREF@("F",DDGFPG,B,F),U,1,4)="^^^" . K @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C") . D COVER . D .. N DX,DY .. S DY=IOSL-6,DX=IOM-9 X IOXY W "EDIT " . ; . N DDGFCOD,DDGFX . D EN^DIR0(C1,C2,$L(C),1,C,"","","","KWT",.DDGFX,.DDGFCOD) . S X=DDGFX . I $P(DDGFCOD,U)="TO"!(X="!M") W $C(7) S X=C . E I X["^" S X=C . E X $P(^DD(.4044,1,0),U,5,999) I '$D(X) W $C(7) S X=C . S C3=C2+$L(X)-1 . ; . S @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")="" . D WRITE^DDGLIBW(DDGFWID,X,C1-P1,C2-P2) . I $L(X)<$L(C) D REPAINT^DDGLIBW(DDGFWID,(C1-P1)_U_(C3+1-P2)_U_1_U_($L(C)-$L(X))) . S $P(@DDGFREF@("F",DDGFPG,B,F),U,1,4)=C1_U_C2_U_C3_U_X,$P(^(F),U,9)=1 ; I T="D" D . K C,C1,C2,C3 . S $P(@DDGFREF@("F",DDGFPG,B,F),U,5,8)="" . K @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F) . D COVER,^DDGFADL . ; . S $P(@DDGFREF@("F",DDGFPG,B,F),U,5,8)=D1_U_D2_U_D3_U_L,$P(^(F),U,9)=1 . S @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")="" . D WRITE^DDGLIBW(DDGFWID,D,D1-P1,D2-P2) ; D RC(DY,DX) Q ; GETELEM(DY,DX) ;Which element is the cursor on ;Returns P,B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2 ;If on pop-up page border, return only B="P",F="P",T="PTOP" or "PBRC" ;Set P=page,B=Block,F=DDO,T=type ("D" or "C") ;If cursor is not on anything, $G(F)="" ; Q:'$D(@DDGFREF@("RC",DDGFWID,DY)) N X1,X2,F1 S X1="" K F F S X1=$O(@DDGFREF@("RC",DDGFWID,DY,X1)) Q:X1=""!(DXX2 .. S B=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2,"")) .. S F=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2,B,"")) .. S T=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2,B,F,"")) Q:"P"[$G(F) ; S P1=$P(DDGFLIM,U),P2=$P(DDGFLIM,U,2) S F1=$G(@DDGFREF@("F",DDGFPG,B,F)) ; ;Get caption, data, and coordinates S C1=$P(F1,U),C2=$P(F1,U,2),C3=$P(F1,U,3),C=$P(F1,U,4) I $P(F1,U,8)]"" D . S D1=$P(F1,U,5),D2=$P(F1,U,6),D3=$P(F1,U,7) . S L=$P(F1,U,8),D=$TR($J("",L)," ","_") Q ; COVER ;Look for covered (hidden) fields ;Input: ; T,C,C1,C2,P1,P2 ;H(DDO) - array of hidden fields ;Erase the element we've selected from buffer ;Redraw the element(s) that were covered N H,O,X1,X2,Y F Y="C1","D1" D . I Y="C1",T'="C" Q . I Y="D1",'$D(D) Q . S X1="" . F S X1=$O(@DDGFREF@("RC",DDGFWID,@Y,X1)) Q:X1="" D .. S X2="" .. F S X2=$O(@DDGFREF@("RC",DDGFWID,@Y,X1,X2)) Q:X2="" D ... N B ... S B=$O(@DDGFREF@("RC",DDGFWID,@Y,X1,X2,"")) ... S O=$O(@DDGFREF@("RC",DDGFWID,@Y,X1,X2,B,"")) ... I O]"",$D(H(O))[0 D .... I T="C",$$OVERLAP(C2,C3,X1,X2) S H(O)=DDGFPG_U_B .... E I $D(D),$$OVERLAP(D2,D3,X1,X2) S H(O)=DDGFPG_U_B ; ;Clear in buffer area occupied by element(s) selected D:T="C" CLEAR(C,C1,C2,C3) D:$D(D) CLEAR(D,D1,D2,D3) ; ;Write to buffer the overlapped field(s) I $D(H) S H="" F S H=$O(H(H)) Q:H="" D . S O=$G(@DDGFREF@("F",$P(H(H),U),$P(H(H),U,2),H)) Q:O="" . D WRITE^DDGLIBW(DDGFWID,$P(O,U,4),$P(O,U)-P1,$P(O,U,2)-P2,"",1) . I $P(O,U,8)>0 D WRITE^DDGLIBW(DDGFWID,$TR($J("",$P(O,U,8))," ","_"),$P(O,U,5)-P1,$P(O,U,6)-P2,"",1) Q ; OVERLAP(A1,A2,B1,B2) ;Does line with X-coords A1,A2 overlap B1,B2 N T I A1B2)!(A2'B2)) ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N S I DDGFR D . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W S_$J("",7-$L(S)) S DY=DDGFY,DX=DDGFX X IOXY Q ; CLEAR(C,C1,C2,C3) ;Clear in buffer area occupied by element(s) selected ;If on the page border, redraw the lines N L S L=$J("",$L(C)-$S(C3>$P(DDGFLIM,U,4):C3-$P(DDGFLIM,U,4),1:0)) D WRITE^DDGLIBW(DDGFWID,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1) ; I $P(@DDGFREF@("F",DDGFPG),U,3) D . I C1=$P(DDGFLIM,U)!(C1=$P(DDGFLIM,U,3)) D .. S L=$TR(L," ",$P(DDGLGRA,DDGLDEL,3)) .. S:C2=$P(DDGFLIM,U,2) $E(L)=$P(DDGLGRA,DDGLDEL,$S(C1=$P(DDGFLIM,U):5,1:7)) .. S:C3'<$P(DDGFLIM,U,4) $E(L,$L(L))=$P(DDGLGRA,DDGLDEL,$S(C1=$P(DDGFLIM,U):6,1:8)) .. D WRITE^DDGLIBW(DDGFWID,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1) . E I C2=$P(DDGFLIM,U,2) D .. D WRITE^DDGLIBW(DDGFWID,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1) . E I C3'<$P(DDGFLIM,U,4) D .. D WRITE^DDGLIBW(DDGFWID,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),$P(DDGFLIM,U,4)-$P(DDGFLIM,U,2),"G",1) Q DDGFFLD^INT^1^60300,29508^0 DDGFFLD ;SFISC/MKO-EDIT A FIELD ;01:47 PM 22 Nov 1994 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. EDIT ; Q:$D(^DIST(.404,B,40,F,0))[0 I T="D" Q:C]"" K @DDGFREF@("F",DDGFPG,B,F) ; S DDGFDY=DY,DDGFDX=DX S DDGFTYPE=$P(^DIST(.404,B,40,F,0),U,3) I 'DDGFTYPE D . I $G(^DIST(.404,B,40,F,20))'?."^" S DDGFTYPE=2 Q . I $P($G(^DIST(.404,B,0)),U,2),$G(^DIST(.404,B,40,F,1)) S DDGFTYPE=3 G:'DDGFTYPE EDITQ ; S DDGFB2=@DDGFREF@("F",DDGFPG,B) S DDGFB1=$P(DDGFB2,U),DDGFB2=$P(DDGFB2,U,2) S DDGFDD=$P(^DIST(.404,B,0),U,2) S (DDGFSUP,DDGFSUP0)=$S(C]""&(DDGFTYPE'=1):$E(C,$L(C))'=":",1:"") S (DDGFCAP,DDGFCAP0)=$S(DDGFTYPE=1!DDGFSUP0:C,1:$E(C,1,$L(C)-1)) S (DDGFCC,DDGFCC0)=$S(C]"":C1-DDGFB1+1_","_(C2-DDGFB2+1),1:"") I $D(D) D . S (DDGFDL,DDGFDL0)=L . S (DDGFDC,DDGFDC0)=D1-DDGFB1+1_","_(D2-DDGFB2+1) K DDGFB1,DDGFB2 ; S DDSFILE=.404,DDSFILE(1)=.4044,DDSPARM="KSTW" S DR="[DDGF FIELD "_$P("CAPTION ONLY^FORM ONLY^DD^COMPUTED",U,DDGFTYPE)_"]" S DA=F,DA(1)=B D . N B,F,T,C,C1,C2,D,D1,D2,L,P1,P2 . D ^DDS K DDSFILE,DDSPARM,DR,DDGFDD ; ;If caption, caption coords, data length, data coords, or suppress ;colon flag changed we need to update some local variables I $D(DA)#2,$G(DDSSAVE) D . S DDGFNDB=$G(@DDGFREF@("F",DDGFPG,B)) . S:DDGFCAP="" (DDGFSUP,DDGFCC)="" . S DR="" . ; . I DDGFCAP'=DDGFCAP0!(DDGFSUP'=DDGFSUP0) D .. S C=DDGFCAP_$S(DDGFCAP]""&(DDGFTYPE'=1)&'DDGFSUP:":",1:"") .. S:DDGFCAP'=DDGFCAP0 DR=DR_"1////"_$S(DDGFCAP]"":DDGFCAP,1:"@")_";" .. S:DDGFSUP'=DDGFSUP0 DR=DR_"5.2////"_$S(DDGFSUP:1,1:"@")_";" . ; . D:DDGFCC'=DDGFCC0 .. S C1=$S(DDGFCAP]"":$P(DDGFCC,",")-1+$P(DDGFNDB,U),1:"") .. S C2=$S(DDGFCAP]"":$P(DDGFCC,",",2)-1+$P(DDGFNDB,U,2),1:"") .. S DR=DR_"5.1////"_$S(DDGFCC]"":DDGFCC,1:"@")_";" . ; . D:$D(D) .. D:DDGFDC'=DDGFDC0 ... S D1=$P(DDGFDC,",")-1+$P(DDGFNDB,U) ... S D2=$P(DDGFDC,",",2)-1+$P(DDGFNDB,U,2) ... S DR=DR_"4.1////"_DDGFDC_";" .. D:DDGFDL'=DDGFDL0 ... S L=DDGFDL ... S D=$TR($J("",L)," ","_") ... S DR=DR_"4.2////"_DDGFDL_";" . ; . I T="D",C]"" D .. D WRITE^DDGLIBW(DDGFWID,C,C1-P1,C2-P2,"",1) .. S @DDGFREF@("RC",DDGFWID,C1,C2,C2+$L(C)-1,B,F,"C")="" . ; . I DR]"" D .. N B,F,T,C,C1,C2,D,D1,D2,L,P1,P2 .. S DIE="^DIST(.404,"_DA(1)_",40," .. S DR=$E(DR,1,$L(DR)-1) .. D ^DIE ; K DA,DDGFNDB K DDGFSUP,DDGFSUP0,DDGFCAP,DDGFCAP0,DDGFCC,DDGFCC0 K DDGFDL,DDGFDL0,DDGFDC,DDGFDC0,DDSSAVE K DIE,DR ; D REFRESH^DDGF,RC(DDGFDY,DDGFDX) EDITQ S DDGFE=1 K DDGFDY,DDGFDX,DDGFTYPE Q ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N S I DDGFR D . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W S_$J("",7-$L(S)) S DY=DDGFY,DX=DDGFX X IOXY Q DDGFFLDA^INT^1^60300,29508^0 DDGFFLDA ;SFISC/MKO-ADD A FIELD ;2:22 PM 13 Sep 1995 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ADD ;Add a field I '$O(^DIST(.403,+DDGFFM,40,DDGFPG,40,0)) D Q . D MSG^DDGF($C(7)_"There are no blocks defined on this page. To add a block, press B.") . H 2 D MSG^DDGF() S DDGFDY=DY,DDGFDX=DX ; ;Invoke form to select block, field order, field type K DDGFBLCK,DDGFFORD,DDGFTYPE S DDSFILE=.404,DDSFILE(1)=.4044 S DR="[DDGF FIELD ADD]",DDSPARM="KTW" D ^DDS K DDSFILE,DA,DR,DDSPARM ; I '$D(DDGFBLCK)!'$D(DDGFFORD)!'$D(DDGFTYPE) G ADDQ ; ;Get relative field coordinates S (DDGFCAP,DDGFCAP0)="" S (DDGFSUP,DDGFSUP0)="" S (DDGFCC,DDGFCC0)="" ; S DDGFB2=@DDGFREF@("F",DDGFPG,DDGFBLCK) S DDGFB1=$P(DDGFB2,U),DDGFB2=$P(DDGFB2,U,2) ; I DDGFTYPE=1 D . S DDGFCC0=DDGFDY-DDGFB1+1_","_(DDGFDX-DDGFB2+1) E D . S DDGFD1=DDGFDY-DDGFB1+1,DDGFD2=DDGFDX-DDGFB2+1 . S (DDGFDC,DDGFDC0)=DDGFD1_","_DDGFD2 . S (DDGFDL,DDGFDL0)=1 ; I DDGFTYPE'=1,DDGFD1<1!(DDGFD2<1) D G ADDQ . D MSG^DDGF($C(7)_"Unable to add a field above or to the left of the block.") . H 2 D MSG^DDGF() ; K DDGFD1,DDGFD2 ; ;Add field order to block file S DIC="^DIST(.404,"_DDGFBLCK_",40,",DIC(0)="L" S DIC("P")=$P(^DD(.404,40,0),U,2) S DA(1)=DDGFBLCK,X=DDGFFORD K DD,DO D FILE^DICN I Y=-1 K DIC,DA,Y D MSG^DDGF($C(7)_"Unable to add field.") H 2 D MSG^DDGF() G ADDQ ; ;Stuff values for field type, data coordinate, and data length ;If form-only field, also stuff in default read type S DIE=DIC,DA(1)=DDGFBLCK,DA=+Y S DR="2////"_DDGFTYPE S:DDGFTYPE'=1 DR=DR_";4.1////"_DDGFDC_";4.2////1" S:DDGFTYPE=2 DR=DR_";20.1////F" D ^DIE K DIC,DIE,DR,Y ; ;Invoke appropriate form S DDSFILE=.404,DDSFILE(1)=.4044,DDSPARM="CKTW" S DDGFDD=$P(^DIST(.404,DDGFBLCK,0),U,2) S DR="[DDGF FIELD "_$P("CAPTION ONLY^FORM ONLY^DD^COMPUTED",U,DDGFTYPE)_"]" D ^DDS K DDSFILE,DR,DDSPARM,DDGFDD ; I $D(DA)#2,DDGFTYPE'=1,$G(DDSCHANG)'=1 D . S DIK="^DIST(.404,"_DA(1)_",40," . D ^DIK K DIK E I $D(DA)#2 D . D SAVE . D LOADF ; ADDQ ;Refresh and cleanup D REFRESH^DDGF D RC(DDGFDY,DDGFDX) ; K DA,DDSCHANG K DDGFB1,DDGFB2,DDGFD1,DDGFD2 K DDGFSUP,DDGFSUP0,DDGFCAP,DDGFCAP0,DDGFCC,DDGFCC0 K DDGFDL,DDGFDL0,DDGFDC,DDGFDC0 K DDGFDY,DDGFDX,DDGFBLCK,DDGFFORD,DDGFTYPE Q ; SAVE ;Save changes to caption, coordinates, data length, and suppress ;colon flag S:DDGFCAP="" (DDGFSUP,DDGFCC)="" S DR="" ; S:DDGFCAP]"" DR=DR_"1////"_DDGFCAP_";" S:DDGFCC]"" DR=DR_"5.1////"_DDGFCC_";" S:DDGFSUP DR=DR_"5.2////1;" ; I DDGFTYPE'=1 D . S:DDGFDC'=DDGFDC0 DR=DR_"4.1////"_DDGFDC_";" . S:DDGFDL'=DDGFDL0 DR=DR_"4.2////"_DDGFDL_";" I DR="" K DR Q ; S DIE="^DIST(.404,"_DA(1)_",40," S DR=$E(DR,1,$L(DR)-1) D ^DIE K DIE,DR,Y Q ; LOADF ;Set DDGFREF and window buffer N C,C1,C2,C3,D,D1,D2,D3,L ; I DDGFCAP="" D . S (C,C1,C2,C3)="" . K @DDGFREF@("F",DDGFPG,DDGFBLCK,DA) E D . S C=DDGFCAP_$S(DDGFTYPE'=1&'DDGFSUP:":",1:"") . S C1=$P(DDGFCC,",")-1+DDGFB1 . S C2=$P(DDGFCC,",",2)-1+DDGFB2 . S C3=C2+$L(C)-1 . ; . S @DDGFREF@("F",DDGFPG,DDGFBLCK,DA)=C1_U_C2_U_C3_U_C . S @DDGFREF@("RC",DDGFWID,C1,C2,C3,DDGFBLCK,DA,"C")="" . D WRITE^DDGLIBW(DDGFWID,C,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1) ; I DDGFTYPE'=1 D . S D1=$P(DDGFDC,",")-1+DDGFB1 . S D2=$P(DDGFDC,",",2)-1+DDGFB2 . S D3=D2+DDGFDL-1 . ; . S $P(@DDGFREF@("F",DDGFPG,DDGFBLCK,DA),U,5,8)=D1_U_D2_U_D3_U_DDGFDL . I D1]"",D2]"" S @DDGFREF@("RC",DDGFWID,D1,D2,D3,DDGFBLCK,DA,"D")="" . D:DDGFDL WRITE^DDGLIBW(DDGFWID,$TR($J("",DDGFDL)," ","_"),D1-$P(DDGFLIM,U),D2-$P(DDGFLIM,U,2),"",1) Q ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N S I DDGFR D . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W S_$J("",7-$L(S)) S DY=DDGFY,DX=DDGFX X IOXY Q DDGFFM^INT^1^61593,58381^0 DDGFFM ;SFISC/MKO-FORM ADD, EDIT, SELECT ;5AUG2009 ;;22.0;VA FileMan;**999,1034,1035**;Mar 30, 1999 ; SEL ;Select another form ADD ;Add a new form N X,DIR0 K DDGFABT S DDGFDY=+$G(DY),DDGFDX=+$G(DX),(DY,DX)=0 X IOXY W $P(DDGLCLR,DDGLDEL,2) X DDGLZOSF("EON"),DDGLZOSF("TRMOFF") ; ;Select file FIL S DDS1=8107 D W^DICRW K DDS1 G:Y<0 ADDQ ;**CCO/NI EDIT/CREATE FORM G:'$D(@(DIC_"0)")) ADDQ ; ;Select form W ! S DIC("S")="I $P(^(0),U,8)=+DDGFFILE" I DUZ(0)'="@" S DIC("S")=DIC("S")_" N DDSI F DDSI=1:1:$L($P(^(0),U,3)) I DUZ(0)[$E($P(^(0),U,3),DDSI) Q" S DDGFFILE=Y,DIC=.403,DIC(0)="QEAL",D="F"_+Y D IX^DIC K DIC,D G:Y<0 ADDQ S DDGFY=Y ; ;Save data for previous form I DDGFCHG,$D(DDGFFM)#2 G:+DDGFFM=+DDGFY ADDQ D G:$G(DDGFABT) ADDQ . N DDGFFNAM . S DIR(0)="Y",DDGFFNAM=$P(DDGFFM,U,2) . S DIR("A")="Save changes to form "_DDGFFNAM . S DIR("B")="YES" . S DIR("?",1)=" Enter 'Y' or press 'Return' to save changes." . S DIR("?",2)=" Enter 'N' to discard changes." . S DIR("?")=" Enter '^' to return to form "_DDGFFNAM . W ! D ^DIR K DIR I $D(DIRUT) K DIRUT,DUOUT,DTOUT S DDGFABT=1 Q . D SAVE^DDGFSV ; I $D(DDGFFM)#2,+DDGFFM'=+DDGFY D RECOMP^DDGF0 ; S DDGFFM=$P(DDGFY,U,1,2) ; ;Stuff in values for form K DR S DIE=.403,DA=+DDGFY,DDGFNEW=$P(DDGFY,U,3) S:DDGFNEW DR="3////"_DUZ_";4///NOW" S DR=$S($G(DR)]"":DR_";",1:"")_"5///NOW" S:DDGFNEW DR=DR_";7////"_+DDGFFILE D ^DIE K DIE,DA,DR,D,%DT I DDGFNEW,$G(DUZ(0))]"" D . S $P(^DIST(.403,+DDGFFM,0),U,2,3)=DUZ(0)_U_DUZ(0) ; ;If this is a new form, create Page 1 N GFT I DDGFNEW D Q:$D(GFT) . K DD,DO . S DIC="^DIST(.403,+DDGFFM,40,",DIC("P")=$P(^DD(.403,40,0),U,2) . S DIC(0)="",DA(1)=+DDGFFM,X=1 . D FILE^DICN I Y=-1 K DIC,Y Q . S DIE=DIC,DA=+Y,DR="2////1,1;7////Page 1" . D ^DIE K DIC,DIE,DA,DR,D,Y SELPAGE .S Y=^DIC(+DDGFFILE,0,"GL") I $P($G(@(Y_"0)")),U,4)<999 D I Y=1 D GFT K DDGFFM W !!,"DONE!",! Q ..N DIR S DIR(0)="Y",DIR("A")="Do you want your Form to begin with a display of all entries, for selection" ..S DIR("?")="Answer YES to save setup time!",DIR("?",1)="Your Form can automatically present a scrolling list of all entries" ..I $O(^DD(+DDGFFILE,0,"ID",0)) S DIR("?",2)="including IDENTIFIER fields" ..D ^DIR ; ;Clear data for previous form W $P(DDGLCLR,DDGLDEL,2) I $D(@DDGFREF) K @DDGFREF D DESTALL^DDGLIBW ; ;Get first page, load form S DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B","")) I DDGFPG]"" S DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B",DDGFPG,"")) D PG^DDGFLOAD(+DDGFFM,DDGFPG),STATUS^DDGF S DDGFDY=$P(DDGFLIM,U),DDGFDX=$P(DDGFLIM,U,2) ; ADDQQ X DDGLZOSF("EOFF"),DDGLZOSF("TRMON") D RC(DDGFDY,DDGFDX) K DDGFABT,DDGFDY,DDGFDX,DDGFNEW,DDGFY Q ; ; GFT ;BUILD A SELECTION PAGE N DIC,FLD,LN,L,DLAYGO,GFTQUIT,GFTID,GFTPOS,DDGH S (DLAYGO,DIC)=.404,X=$P(DDGFY,U,2),DIC(0)="LX",DIC("DR")="1////"_+DDGFFILE D FILE^DICN ;CREATE NEW BLOCK FOR DATA S DDGFBLK=+Y Q:'$P(Y,U,3) S (DLAYGO,DIC)=.404,X=$P(DDGFY,U,2)_" HEADER",DIC(0)="LX",DIC("DR")="1////"_+DDGFFILE D FILE^DICN ;CREATE NEW HEADER BLOCK S DDGH=+Y S FLD=0,GFTID=U,GFTPOS=2 S GFT=.01 F S FLD=FLD+1 D Q:$G(GFTQUIT) S GFT=$O(^DD(+DDGFFILE,0,"ID",GFT)) Q:'GFT .D FIELD^DID(+DDGFFILE,GFT,"","FIELD LENGTH;LABEL","GFT(GFT)") .S L=GFT(GFT,"LABEL") I $L(GFTID)+$L(L)+$L(GFTID,U)>74 S GFTQUIT=1,FLD=FLD-1 Q ;HEADER RESTRICTS NUMBER OF FIELDS .S LN=GFT(GFT,"FIELD LENGTH") S:LN>74 LN=74 S GFTID(FLD)=LN,GFTPOS(FLD)=GFTPOS,GFTPOS=GFTPOS+LN+2,GFTID(FLD,1)=GFT,GFTID=GFTID_L_U F S L=GFTPOS-79\FLD Q:L<1 S LN=0 F X=1:1:FLD D .I GFTID(X)-1<6 Q .S GFTID(X)=GFTID(X)-1,GFTPOS=GFTPOS-1,GFTPOS(X)=GFTPOS(X)-LN,LN=LN+1 ;TRIM FIELD LENGTHS BY 1 F X=1:1 Q:'$D(GFTID(X)) D .S DIC="^DIST(.404,"_DDGFBLK_",40,",DLAYGO=.4044,DA(1)=DDGFBLK,DIC(0)="LX" .S DIC("DR")="2////3;3.1////"_$P(GFTID,U,X+1)_";4////"_GFTID(X,1)_";4.1///2,"_GFTPOS(X)_";4.2///"_GFTID(X) .D FILE^DICN ;CREATE A DATA FIELD S DIC="^DIST(.404,"_DDGH_",40,",DA(1)=DDGH,DIC(0)="LX",X=1,DIC("DR")="2///4;4.1///1,1;4.2///80;30///S Y=$$HEADER^DDGFFM("_+DDGFFM_")" D FILE^DICN ;CREATE THE HEADER FIELD S GFT=^DIC(+DDGFFILE,0,"GL") I '$D(^DD(+DDGFFILE,0,"IX","B",+DDGFFILE,.01)) S GFT="F D=0:0 S D=$O("_GFT E S GFT="S GFT="""" F S GFT=$O("_GFT_"""B"",GFT)) Q:GFT="""" F D=0:0 S D=$O("_GFT_"""B"",GFT," ;SHOW ENTRIES ALPHABETICALLY IF THERE IS A "B" X-REF S GFT=GFT_"D)) Q:'D N Y S (Y,D0)=D "_$G(^DD(+DDGFFILE,0,"SCR"))_" X DICMX Q:'$D(D)" S DIE=.403,DA=+DDGFFM,DR="21///1" D ^DIE ;FORM'S RECORD SELECTION PAGE=1 S DIC="^DIST(.403,"_DA_",40,1,40,",DA(2)=DA,DA(1)=1,(X,DINUM)=DDGFBLK,DIC(0)="UXL",DIC("P")=".4032IP",DLAYGO=.4032 S DIC("DR")="1///1;2///2,1;3///e;5///15;98.1///"_+DDGFFILE_";98////^S X=GFT" D FILE^DICN ;ADD DATA BLOCK TO PAGE S DIE="^DIST(.403,"_+DDGFFM_",40,",DR="1////"_DDGH,DA=1 D ^DIE ;ADD HEADER BLOCK POINTER Q ; ; HEADER(FORM) ;GIVES NICE HEADER LINE. CALLED BY HEADER BLOCK COMPUTED EXPRESSION N B,X,F,S,L,D,FILE,Y,FILENAME,LINE S X="",S=0,B=$O(^DIST(.403,FORM,"AY",1,0)) I 'B Q X S FILE=$P(^(B),U,3) Q:'FILE F F=0:0 S F=$O(^DIST(.403,FORM,"AY",1,B,F)) Q:'F S Y=$G(^(F,"D")) Q:'Y S:'$D(LINE) LINE=+Y Q:Y>LINE D .S L=$P(Y,U,3) Q:'L .S D=$P(Y,U,2) I D>S S X=X_$J("",D-S),S=D .S D=$P(Y,U,4),Y=$$LABEL^DIALOGZ(FILE,D) D:$L(Y)>L S Y=$E(Y,1,L) ..N Z,T F Z=0:0 S Z=$O(^DIST(.404,B,40,Z)) Q:'Z I $G(^(Z,1))=D S T=$P(^(0),U,5) I T]"",$L(T)<$L(Y) S Y=T Q ;TRY SHORTER 'UNIQUE NAME' .I F=1,$L(Y)+30 S DDGFLIST(+$P(DDGFLN,U,5),+$P(DDGFLN,U,6),DDO)="" . E I $P(DDGFLN,U,4)]"" S DDGFLIST(+$P(DDGFLN,U),+$P(DDGFLN,U,2),DDO)="" ; K ^DIST(.404,DDGFBK,40,"B") S DDGFN=0 S DDGFR="" F S DDGFR=$O(DDGFLIST(DDGFR)) Q:DDGFR="" D . S DDGFC="" F S DDGFC=$O(DDGFLIST(DDGFR,DDGFC)) Q:DDGFC="" D .. S DDO="" F S DDO=$O(DDGFLIST(DDGFR,DDGFC,DDO)) Q:DDO="" D ... S DDGFN=DDGFN+1 ... S DDGFO=$P(^DIST(.404,DDGFBK,40,DDO,0),U) ... S:DDGFO'=DDGFN $P(^DIST(.404,DDGFBK,40,DDO,0),U)=DDGFN ; S DIK="^DIST(.404,DDGFBK,40,",DA(1)=DDGFBK,DIK(1)=".01^B" D ENALL^DIK D MSG^DDGF("Reordering completed.") H 1 D MSG^DDGF() Q DDGFPG^INT^1^60300,29508^0 DDGFPG ;SFISC/MKO-ADD A NEW PAGE ;2:26 PM 13 Sep 1995 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; ADD ;Invoke forms to add a new page S DDGFDY=DY,DDGFDX=DX K DDGFPNUM ; ;Ask for new page number S DDSFILE=.403,DDSFILE(1)=.4031 S DA(1)=+DDGFFM,DA="",DR="[DDGF PAGE ADD]",DDSPARM="KTW" D ^DDS K DDSFILE,DA,DR,DDSPARM ; G:$D(DDGFPNUM)[0 ADDQ ; ;Ask 'are you sure' page should be added K DDGFANS S DDSFILE=.403,DDSFILE(1)=.4031 S DR="[DDGF PAGE ADD]",DA(1)=+DDGFFM,DA="",DDSPARM="KTW",DDSPAGE=11 D ^DDS K DDSFILE,DA,DR,DDSPARM,DDSPAGE ; I '$G(DDGFANS) K DDGFANS G ADDQ K DDGFANS ; ;Add page to form S DIC="^DIST(.403,+DDGFFM,40,",DIC(0)="L",DA(1)=+DDGFFM S DIC("P")=$P(^DD(.403,40,0),U,2),X=DDGFPNUM K DD,DO D FILE^DICN K DIC,DA,X G:Y=-1 ADDQ S DDGFPG=+Y ; ;Stuff in values for coordinates and name S DIE="^DIST(.403,"_+DDGFFM_",40,",DA(1)=+DDGFFM,DA=DDGFPG S DR="2////1,1;7////Page "_DDGFPNUM D ^DIE K DIE,DA,DR ; K DDGFPNUM D LOADPG S DDGFNEW=1 G EDIT ; ADDQ D REFRESH^DDGF,RC(DDGFDY,DDGFDX) K DDGFPNUM,DDGFDY,DDGFDX Q ; EDIT ;Invoke form to edit a page ;Input: DDGFNEW (optional) ; Set by ADD to indicate this is a brand new page. ; S DDGFDY=DY,DDGFDX=DX S DDGFND=@DDGFREF@("F",DDGFPG) S (DDGFTLC,DDGFTLC0)=$P(DDGFND,U)+1_","_($P(DDGFND,U,2)+1) S (DDGFLRC,DDGFLRC0)=$S($P(DDGFND,U,3)]"":$P(DDGFND,U,3)+1_","_($P(DDGFND,U,4)+1),1:"") S (DDGFPNM,DDGFPNM0)=$P(DDGFND,U,5) S DDGFPAR=$P($G(^DIST(.403,+DDGFFM,40,DDGFPG,1)),U,2) ; S DDSFILE=.403,DDSFILE(1)=.4031,DDSPARM="KTW" S DA(1)=+DDGFFM,DA=DDGFPG,DR="[DDGF PAGE EDIT]" D ^DDS K DDSFILE,DA,DR,DDSPARM ; S DDGFND=$G(^DIST(.403,+DDGFFM,40,DDGFPG,0)) ; ;If page was deleted, destroy windows and set new page I DDGFND="" D Q:DDGFE . I $D(DDGFWID)#2,$$EXIST^DDGLIBW(DDGFWID) D DESTROY^DDGLIBW(DDGFWID) . I $D(DDGFWIDB)#2,$$EXIST^DDGLIBW(DDGFWIDB) D DESTROY^DDGLIBW(DDGFWIDB) . K @DDGFREF@("F",DDGFPG),@DDGFREF@("RC",DDGFWID),@DDGFREF@("BKRC",DDGFWIDB) . I $D(@DDGFREF@("ASUB","B",DDGFPG)) D DEL^DDGFASUB(DDGFPG) . S DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B","")) . S:DDGFPG]"" DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B",DDGFPG,"")) . D LOADPG,REFRESH^DDGF,RC(DDGFDY,DDGFDX) ; E D . S:DDGFPNM'=DDGFPNM0 $P(@DDGFREF@("F",DDGFPG),U,5)=DDGFPNM,$P(^(DDGFPG),U,7)=1,DDGFCHG=1 . D:DDGFPAR'=$P($G(^DIST(.403,+DDGFFM,40,DDGFPG,1)),U,2) EDIT^DDGFASUB(DDGFPG) . I DDGFTLC'=DDGFTLC0!(DDGFLRC'=DDGFLRC0) D .. D PAGE^DDGFUPDP($P(DDGFTLC,",")-1,$P(DDGFTLC,",",2)-1,$S(DDGFLRC]"":$P(DDGFLRC,",")-1,1:""),$S(DDGFLRC]"":$P(DDGFLRC,",",2)-1,1:""),$S(DDGFTLC=DDGFTLC0:"PBRC",1:"PTOP")) .. D STATUS^DDGF,RC($P(DDGFLIM,U),$P(DDGFLIM,U,2)) . E D REFRESH^DDGF,RC(DDGFDY,DDGFDX) ; K DDGFDX,DDGFDY,DDGFND,DDGFNEW K DDGFLRC,DDGFLRC0,DDGFPOP,DDGFPOP0,DDGFTLC,DDGFTLC0 K DDGFPAR,DDGFPNM,DDGFPNM0 Q ; PGSEL ;Select a new page S DDGFDY=DY,DDGFDX=DX,DDGFPAGE=DDGFPG ; S DDSFILE=.403,DDSFILE(1)=.4031 S DR="[DDGF PAGE SELECT]",DDSPARM="KTW" D ^DDS K DDSFILE,DA,DR,DDSPAGE,DDSPARM ; I DDGFPAGE]"",DDGFPAGE'=DDGFPG S DDGFPG=DDGFPAGE D LOADPG ; D REFRESH^DDGF,RC(DDGFDY,DDGFDX) K DDGFPAGE,DDGFDY,DDGFDX Q ; NXTPRV(F) ;Go to page ;F=1:next page; -1:previous page S DDGFPAGE=$P($G(^DIST(.403,+DDGFFM,40,DDGFPG,0)),U,$S($G(F)=-1:5,1:4)) G:DDGFPAGE="" NXTPRVQ S DDGFPAGE=$O(^DIST(.403,+DDGFFM,40,"B",DDGFPAGE,"")) G:$D(^DIST(.403,+DDGFFM,40,+DDGFPAGE,0))[0!(DDGFPAGE=DDGFPG) NXTPRVQ ; S DDGFPG=DDGFPAGE D LOADPG,REFRESH^DDGF,RC(DDGFDY,DDGFDX) NXTPRVQ K DDGFPAGE,DDGFDY,DDGFDX Q ; CLSPG ;Close page Q:$G(DDGLSCR)'>1 D CLOSE^DDGLIBW(DDGFWID) S DDGFPG=$E(DDGLSCR(DDGLSCR),2,999) D PG^DDGFLOAD(+DDGFFM,DDGFPG,1) D STATUS^DDGF,RC($P(DDGFLIM,U),$P(DDGFLIM,U,2)) Q ; SUBPG ;Go into subpage I $D(@DDGFREF@("ASUB",DDGFPG,B,F))#2 S DDGFSUBP=^(F) E D . S DDGFSUBP=+$P($G(^DIST(.404,B,40,F,7)),U,2) . S DDGFSUBP=+$O(^DIST(.403,+DDGFFM,40,"B",DDGFSUBP,"")) ; I $D(^DIST(.403,+DDGFFM,40,DDGFSUBP,0))[0 W $C(7) K DDGFSUBP Q I DDGFSUBP=DDGFPG K DDGFSUBP Q S DDGFE=1 Q ; SUBPG1 S DDGFPG=DDGFSUBP K DDGFSUBP D PG^DDGFLOAD(+DDGFFM,DDGFPG) D STATUS^DDGF,RC($P(DDGFLIM,U),$P(DDGFLIM,U,2)) Q ; LOADPG ;Load new page D PG^DDGFLOAD(+DDGFFM,DDGFPG,1) S DDGFDY=$P(DDGFLIM,U),DDGFDX=$P(DDGFLIM,U,2) Q ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N S I DDGFR D . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W S_$J("",7-$L(S)) S DY=DDGFY,DX=DDGFX X IOXY Q DDGFSV^INT^1^60300,29508^0 DDGFSV ;SFISC/MKO- SAVE DATA ;12:41 PM 29 Mar 1995 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. SAVE ;Save in form/block files data in DDGFREF N P,B,F,P1,B1,F1,N ; I '$G(DDGFCHG) D MSG^DDGF("Nothing to save.") H 1 D MSG^DDGF() Q D MSG^DDGF("Saving data ...") ; ;Loop through all pages in DDGFREF S P="" F S P=$O(@DDGFREF@("F",P)) Q:P="" D PG ; D MSG^DDGF("Data saved.") H 1 D MSG^DDGF() S DDGFCHG=0 Q ; PG ;Save page data S P1=@DDGFREF@("F",P) I $P(P1,U,7),$D(^DIST(.403,+DDGFFM,40,P,0))#2 D . S N=^DIST(.403,+DDGFFM,40,P,0) . S $P(N,U,3)=$P(P1,U)+1_","_($P(P1,U,2)+1) . S $P(N,U,6,7)=$S($P(P1,U,3)="":U,1:1_U_($P(P1,U,3)+1)_","_($P(P1,U,4)+1)) . S ^DIST(.403,+DDGFFM,40,P,0)=$$STPU(N) . ; . S N=$G(^DIST(.403,+DDGFFM,40,P,1)) . I $P(N,U)'=$P(P1,U,5) D .. S DIE="^DIST(.403,"_+DDGFFM_",40," .. S DR="7////"_$P(P1,U,5),DA(1)=+DDGFFM,DA=P .. N P D ^DIE K DIE,DR,DA ; ;Loop through all blocks S B="" F S B=$O(@DDGFREF@("F",P,B)) Q:B="" D BK Q ; BK ;Save block data S B1=@DDGFREF@("F",P,B) I $P(B1,U,5),$D(^DIST(.403,+DDGFFM,40,P,40,B,0))#2 D . S $P(^DIST(.403,+DDGFFM,40,P,40,B,0),U,3)=$P(B1,U)-$P(P1,U)+1_","_($P(B1,U,2)-$P(P1,U,2)+1) . I $P(^DIST(.404,B,0),U)'=$P(B1,U,4) D .. S DIE="^DIST(.404,",DR=".01////"_$P(B1,U,4),DA=B .. N B,P D ^DIE K DIE,DR,DA ; ;Loop through all fields S F="" F S F=$O(@DDGFREF@("F",P,B,F)) Q:F="" D FD Q ; FD ;Save field data S F1=@DDGFREF@("F",P,B,F) I $P(F1,U,9),$D(^DIST(.404,B,40,F,0))#2 D . S N="" . S $P(N,U,1,2)=$S($P(F1,U,8):$S($P(F1,U,5)]""&($P(F1,U,6)]""):$P(F1,U,5)-$P(B1,U)+1_","_($P(F1,U,6)-$P(B1,U,2)+1),1:"")_U_$P(F1,U,8),1:U) . S $P(N,U,3,4)=$S($L($P(F1,U,4)):$S($P(F1,U)]""&($P(F1,U,2)]""):$P(F1,U)-$P(B1,U)+1_","_($P(F1,U,2)-$P(B1,U,2)+1),1:"")_U_$S($P(F1,U,4)?.E1":":"",1:1),1:U) . S:$P(^DIST(.404,B,40,F,0),U,3)=1 $P(N,U,4)="" . S ^DIST(.404,B,40,F,2)=$$STPU(N) . ; . ;Use DIE to stuff in new caption . I $P(^DIST(.404,B,40,F,0),U,2)'=$P(F1,U,4) D .. S DIE="^DIST(.404,"_B_",40," .. S DR="1////"_$S($P(F1,U,4)?.1":":"@",$P(F1,U,4)?1.E1":":$E($P(F1,U,4),1,$L($P(F1,U,4))-1),1:$P(F1,U,4)) .. S DA(1)=B,DA=F .. N P,B,F D ^DIE K DIE,DR,DA Q ; STPU(X) ;Strip trailing up-arrows from X N I F I=$L(X):-1:0 Q:$E(X,I)'="^" Q $E(X,1,I) DDGFU^INT^1^60300,29508^0 DDGFU ;SFISC/MKO-CALLED FROM THE FORMS ;10:49 AM 27 Jul 1995 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; VAL1 ;Data validation code ;Form: DDS FIELD ADD I $$GET^DDSVALF("BLOCK","DDGF FIELD ADD")]"",$$GET^DDSVALF("FIELD ORDER","DDGF FIELD ADD")]"",$$GET^DDSVALF("FIELD TYPE","DDGF FIELD ADD")]"" Q ; S DDGFT(1)=$C(7)_"Unable to save values." S DDGFT(2)="All values must be filled in order to add a new field." D HLP^DDSUTL(.DDGFT) S DDSERROR=1 K DDGFT Q ; DDCAP ;Caption, Post action on change ;Form: DDGF FIELD DD N DDGFOPG S DDGFOPG=$$OTHPG D:DDSOLD="!M" PUT^DDSVAL(.4044,.DA,1.1,"") ; D:X="" CAPNULL(DDGFOPG) D:X]"" UPDDC(DDGFOPG) Q ; OTHPG() ;Return Other Params page# N FLD,SUB,OPG S FLD=$$GET^DDSVAL(.4044,.DA,4) I FLD D . S OPG=11 . S SUB=+$P($G(^DD(DDGFDD,FLD,0)),U,2) . S:SUB OPG=$S(SUB_$P($G(^DD(SUB,.01,0)),U,2)'["W":21,1:31) Q $G(OPG) ; FOCAP ;Caption, Post action on change ;Form: DDGF FIELD FORM ONLY D:X'="!M" PUT^DDSVAL(.4044,.DA,1.1,"") ; D:X="" CAPNULL(21) D:X]"" UPDDC(21) Q ; COMPCAP ;Caption, Post action on change ;Form: DDGF FIELD COMPUTED D:X'="!M" PUT^DDSVAL(.4044,.DA,1.1,"") ; D:X="" CAPNULL(11) D:X]"" UPDDC(11) Q ; CAPNULL(OPG) ;Caption changed to null N DC,SC ; ;Clear suppress colon S SC=$$GET^DDSVALF("SUPPRESS COLON AFTER CAPTION?") D PUT^DDSVALF("SUPPRESS COLON AFTER CAPTION?","","","","I") Q:'$G(OPG) ; ;Clear caption coords D PUT^DDSVALF("CAPTION COORDINATE",1,OPG,"") ; ;Move data to the left S DC=$$GET^DDSVALF("DATA COORDINATE",1,OPG) S $P(DC,",",2)=$P(DC,",",2)-$L(DDSOLD)-1-'SC S:$P(DC,",",2)<1 $P(DC,",",2)=1 D PUT^DDSVALF("DATA COORDINATE",1,OPG,DC,"I") Q ; UPDDC(OPG) ;Update data coords N DC,COL S DC=$$GET^DDSVALF("DATA COORDINATE",1,OPG) S COL=$P(DC,",",2),COL=COL+$L(X)-$L(DDSOLD) I DDSOLD="" D . D PUT^DDSVALF("CAPTION COORDINATE",1,OPG,DC,"I") . S COL=COL+2 S:COL<1 COL=1 S $P(DC,",",2)=COL D PUT^DDSVALF("DATA COORDINATE",1,OPG,DC) Q ; POSTCH1 ;Field, Post Action On Change ;Form: DDGF FIELD DD ; ;Reset (if caption not !M): caption, caption and data coords, ; data length ;Input: ; DDGFPG = Page # ; DA(1) = Block # ; DA = Field order ; X = Fld # ; DDSOLD = Prev fld # ; Q:X="" N FILE,FLD,DD,C,C0,CC,DC,SC,L,OPG,OPG0,PLRC ; S FLD=X S FILE=+$P(^DIST(.404,DA(1),0),U,2) Q:'FILE S DD=$G(^DD(FILE,FLD,0)) Q:DD?."^" S OPG=$$OTHPG ; S OPG0=11 I $G(DDSOLD)]"" D . N SUB . S SUB=+$P($G(^DD(FILE,DDSOLD,0)),U,2) . S:SUB OPG0=$S(SUB_$P($G(^DD(SUB,.01,0)),U,2)'["W":21,1:31) ; S (C,C0)=$$GET^DDSVALF("CAPTION",1,1) S:C]"" CC=$$GET^DDSVALF("CAPTION COORDINATE",1,OPG0) S DC=$$GET^DDSVALF("DATA COORDINATE",1,OPG0) ; I OPG'=OPG0 D . D:C]"" PUT^DDSVALF("CAPTION COORDINATE",1,OPG,CC) . D:DC]"" PUT^DDSVALF("DATA COORDINATE",1,OPG,DC) . D DESTROY^DDSUTL(OPG0) . ; I $D(DDGFREF),$D(DDGFPG) S PLRC=$P($G(@DDGFREF@("F",DDGFPG)),U,4) S PLRC=$S($G(PLRC)]"":PLRC-1,1:IOM-2)-$P($G(@DDGFREF@("F",DDGFPG,DA(1))),U,2) S L=$$LENGTH(FILE,FLD) S:'L L=1 ; I C'="!M",$P(DD,U)]"" D . S C=$P(DD,U) . I $P(DD,U,2),$P($G(^DD(+$P(DD,U,2),.01,0)),U,2)'["W" S C="Select "_C . D PUT^DDSVALF("CAPTION",1,1,C) . ; . I C0="" D .. S CC=DC .. S $P(DC,",",2)=$P(DC,",",2)+2 .. D PUT^DDSVALF("CAPTION COORDINATE",1,OPG,CC) . E Q:$P(CC,",")'=$P(DC,",") . ; . S $P(DC,",",2)=$P(DC,",",2)+$L(C)-$L(C0) . S:$P(DC,",",2)<1 $P(DC,",",2)=1 . D PUT^DDSVALF("DATA COORDINATE",1,OPG,DC) ; I C0'="!M",$P(DC,",",2)-2+L>PLRC S L=PLRC-$P(DC,",",2)+2 D PUT^DDSVALF("DATA LENGTH",1,OPG,L) Q ; HBVAL ;Validate hdr blk Q:X="" Q:'$O(@(DIE_DA_",40,""B"",X,"""")")) S DDSERROR=1 D HLP^DDSUTL($C(7)_DDSEXT_" already exists on this page.") Q ; LENGTH(DIFILE,DIFLD) ;Find max field length N DD,DIIT,DILEN,DITYPE S DILEN="" S DD=$G(^DD(DIFILE,DIFLD,0)) Q:DD?."^" DILEN S DITYPE=$P(DD,U,2),DIIT=$P(DD,U,5,999) ; I DIIT["$L(X)>" S DILEN=+$P($P(DIIT,"$L(X)>",2,999),"E") E I DITYPE["N" S DILEN=+$P(DITYPE,"J",2) E I DITYPE["P" S DILEN=$$LENGTH(+$P(DITYPE,"P",2),.01) ; E I DITYPE["S" D . N DICODE,DICODEA,DIPC . S DICODE=$P(DD,U,3) . F DIPC=1:1 S DICODEA=$P(DICODE,";",DIPC) Q:DICODEA="" D .. S DILEN=$$MAX(DILEN,$L($P(DICODEA,":")),$L($P(DICODEA,":",2))) ; E I DITYPE["D" D . N DIDT . S DIDT=$P($P(DIIT,"S %DT=""",2,999),"""") . S DILEN=$S(DIDT["S"&(DIDT["T"):20,DIDT["T":17,1:11) ; E I DITYPE["V" D . N DIL,DIX . S DIX=0 F S DIX=$O(^DD(DIFILE,DIFLD,"V",DIX)) Q:'DIX D .. Q:'$G(^DD(DIFILE,DIFLD,"V",DIX,0)) .. S DIL=$G(DIL)+1 .. S DIL(DIL)=$$LENGTH(+^DD(DIFILE,DIFLD,"V",DIX,0),.01) . S DILEN=$G(DIL(1)) . F DIL=1:1:$G(DIL)-1 S DILEN=$$MAX(DIL(DIL),DIL(DIL+1)) ; E I DITYPE D . Q:$D(^DD(+DITYPE,.01,0))[0 . S DILEN=$S($P(^DD(+DITYPE,.01,0),U,2)["W":1,1:$$LENGTH(+DITYPE,.01)) ; Q DILEN ; MAX(X,Y,Z) ;Return max of 2 or 3 numbers N M S M=$S(X>Y:+X,1:+Y),M=$S(M>$G(Z):M,1:+$G(Z)) Q M DDGFUPDB^INT^1^60300,29508^0 DDGFUPDB ;SFISC/MKO-UPDATE BLOCK COORDINATES ;03:28 PM 17 Aug 1993 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. BLK(DDGFORIG) ; ;Update image with adjusted block coordinates ; DDGFORIG(B) : defined for all blocks that changed coordinates ; = original $Y^original $X N P,P1,P2,B,B1,B2,F,C1,C2,C3,C,D1,D2,D3,L,X1,Y1,N,I ; ;Get page coordinates S P=DDGFPG S P1=$P(@DDGFREF@("F",P),U),P2=$P(@DDGFREF@("F",P),U,2) ; ;Loop through all blocks on page S B="" F S B=$O(@DDGFREF@("F",P,B)) Q:B="" D BK Q ; BK ;Get block coordinates S B2=@DDGFREF@("F",P,B) S B1=$P(B2,U),B2=$P(B2,U,2) ; ;Get Y1=delta $Y, X1=delta $X I $D(DDGFORIG(B)) S Y1=B1-$P(DDGFORIG(B),U),X1=B2-$P(DDGFORIG(B),U,2) E S (Y1,X1)=0 I 'Y1,'X1 K DDGFORIG(B) ; ;Loop through all fields on block S F="" F S F=$O(@DDGFREF@("F",P,B,F)) Q:F="" D FD Q ; FD ; ;Get field data S N=@DDGFREF@("F",P,B,F) S C1=$P(N,U),C2=$P(N,U,2),C3=$P(N,U,3),C=$P(N,U,4) S D1=$P(N,U,5),D2=$P(N,U,6),D3=$P(N,U,7),L=$P(N,U,8) ; I $D(DDGFORIG(B)) D . I Y1 S:C1]"" $P(N,U)=C1+Y1 S:L $P(N,U,5)=D1+Y1 . I X1 D .. I C]"" F I=2,3 S $P(N,U,I)=$P(N,U,I)+X1 .. I L F I=6,7 S $P(N,U,I)=$P(N,U,I)+X1 . S @DDGFREF@("F",P,B,F)=N . ; . I C]"" D .. K @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C") .. S @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,3),B,F,"C")="" . I L D .. K @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D") .. S @DDGFREF@("RC",DDGFWID,$P(N,U,5),$P(N,U,6),$P(N,U,7),B,F,"D")="" ; I C]"" D WRITE^DDGLIBW(DDGFWID,C,$P(N,U)-P1,$P(N,U,2)-P2) I L D WRITE^DDGLIBW(DDGFWID,$TR($J("",L)," ","_"),$P(N,U,5)-P1,$P(N,U,6)-P2) Q DDGFUPDP^INT^1^60300,29508^0 DDGFUPDP ;SFISC/MKO-UPDATE PAGE COORDINATES ;01:37 PM 19 Jan 1994 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; PAGE(P1,P2,P3,P4,T,A) ; ; D DESTROY^DDGLIBW(DDGFWID,1),DESTROY^DDGLIBW(DDGFWIDB,1) I P3]"" D . D REPALL^DDGLIBW($G(A)) . D CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(P3-P1+1)_U_(P4-P2+1),1) . S DDGFLIM=P1_U_P2_U_P3_U_P4 E D . D CLOSEALL^DDGLIBW() . D CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(IOSL-7-P1)_U_(IOM-1-P2)) . S DDGFLIM=P1_U_P2_U_(IOSL-8)_U_(IOM-2) D:T="PTOP" TOP(P1,P2,P3,P4) D:T="PBRC" BRC(P1,P2,P3,P4) Q ; TOP(P1,P2,P3,P4) ;Update page image ; N B,C,C1,C2,C3,D1,D2,D3,F,I,L,N,P,X1,Y1 ; S P=DDGFPG S N=@DDGFREF@("F",P) S Y1=P1-$P(N,U),X1=P2-$P(N,U,2) I 'Y1,'X1 Q ; I $P(N,U,3)]"" D . K @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,4),"P","P","PTOP") . K @DDGFREF@("RC",DDGFWID,$P(N,U,3),$P(N,U,4),$P(N,U,4),"P","P","PBRC") I $G(P3)]"" D . S @DDGFREF@("RC",DDGFWID,P1,P2,P4,"P","P","PTOP")="" . S @DDGFREF@("RC",DDGFWID,P3,P4,P4,"P","P","PBRC")="" ; S $P(N,U,1,4)=P1_U_P2_U_P3_U_P4,$P(N,U,7)=1,DDGFCHG=1 S @DDGFREF@("F",P)=N ; ;Loop through all blocks on page S B="" F S B=$O(@DDGFREF@("F",P,B)) Q:B="" D . S N=@DDGFREF@("F",P,B) . S @DDGFREF@("BKRC",DDGFWIDB,$P(N,U)+Y1,$P(N,U,2)+X1,$P(N,U,3)+X1,B)=@DDGFREF@("BKRC",DDGFWIDB,$P(N,U),$P(N,U,2),$P(N,U,3),B) . K @DDGFREF@("BKRC",DDGFWIDB,$P(N,U),$P(N,U,2),$P(N,U,3),B) . S $P(N,U,1,3)=$P(N,U)+Y1_U_($P(N,U,2)+X1)_U_($P(N,U,3)+X1) . S @DDGFREF@("F",P,B)=N . ; . S F="" F S F=$O(@DDGFREF@("F",P,B,F)) Q:F="" D .. S N=@DDGFREF@("F",P,B,F) .. S C1=$P(N,U),C2=$P(N,U,2),C3=$P(N,U,3),C=$P(N,U,4) .. S D1=$P(N,U,5),D2=$P(N,U,6),D3=$P(N,U,7),L=$P(N,U,8) .. ; .. I Y1 S:C1]"" $P(N,U)=C1+Y1 S:L $P(N,U,5)=D1+Y1 .. I X1 D ... I C]"" F I=2,3 S $P(N,U,I)=$P(N,U,I)+X1 ... I L F I=6,7 S $P(N,U,I)=$P(N,U,I)+X1 .. S @DDGFREF@("F",P,B,F)=N .. ; .. I C]"" D ... K @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C") ... S @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,3),B,F,"C")="" .. I L D ... K @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D") ... S @DDGFREF@("RC",DDGFWID,$P(N,U,5),$P(N,U,6),$P(N,U,7),B,F,"D")="" .. ; .. D:C]"" WRITE^DDGLIBW(DDGFWID,C,$P(N,U)-P1,$P(N,U,2)-P2) .. D:L WRITE^DDGLIBW(DDGFWID,$TR($J("",L)," ","_"),$P(N,U,5)-P1,$P(N,U,6)-P2) Q ; BRC(P1,P2,P3,P4) ;Change bottom right coordinate of page N B,C,F,L,N,P S P=DDGFPG S N=@DDGFREF@("F",P) I $P(N,U,3)]"" D . K @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,4),"P","P","PTOP") . K @DDGFREF@("RC",DDGFWID,$P(N,U,3),$P(N,U,4),$P(N,U,4),"P","P","PBRC") I $G(P3)]"" D . S @DDGFREF@("RC",DDGFWID,P1,P2,P4,"P","P","PTOP")="" . S @DDGFREF@("RC",DDGFWID,P3,P4,P4,"P","P","PBRC")="" ; S $P(N,U,1,4)=P1_U_P2_U_P3_U_P4,$P(N,U,7)=1,DDGFCHG=1 S @DDGFREF@("F",P)=N ; ;Loop through all blocks/fields on page S B="" F S B=$O(@DDGFREF@("F",P,B)) Q:B="" D . S F="" F S F=$O(@DDGFREF@("F",P,B,F)) Q:F="" D .. S N=@DDGFREF@("F",P,B,F) .. S C=$P(N,U,4),L=$P(N,U,8) .. ; .. I C]"" D WRITE^DDGLIBW(DDGFWID,C,$P(N,U)-P1,$P(N,U,2)-P2) .. I L D WRITE^DDGLIBW(DDGFWID,$TR($J("",L)," ","_"),$P(N,U,5)-P1,$P(N,U,6)-P2) Q DDGLBXA^INT^1^60300,29508^0 DDGLBXA ;SFISC/MKO-A LIST BOX ;1:58 PM 26 Apr 1996 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; LIST(DDGLGLO,DDGLOUT,DDGLROW,DDGLCOL,DDGLHT,DDGLWD,DDGLSEL,DDGLFLG,DDGLMAP) ; ;Input: ; DDGLGLO = closed reference of local or global that contains ; the list of entries ; @DDGLGLO("B",entry,index)="" ; DDGLROW = $Y of top left corner ; DDGLCOL = $X of top left corner ; DDGLHT = height of box ; DDGLWD = width of box ; DDGLSEL = text of selected item ; DDGLFLG = flags ; DDGLMAP = array to customize key sequences ; ;Output: ; DDGLOUT = index of selected entry (if any) ; DDGLOUT(0) = selected entry ; DDGLOUT("C") = code indicates what terminated the read ; ;Other variables: N DDGLCID ; window (control) id N DDGLNL ; number of lines in list N DDGLNC ; number of columns in list N DDGLLINE ; current line number N DDGLITEM ; item array ; DDGLITEM(1..DDGLNL) = text of item displayed ; Q:$G(DDGLGLO)="" D INIT X DDGLZOSF("EOFF") W $P(DDGLVID,DDGLDEL,11) ; D ^DDGLBXA1 ; W $P(DDGLVID,DDGLDEL,12) X DDGLZOSF("EON") D DESTROY(DDGLCID,$G(DDGLFLG)) Q ; CREATE(DDGLGLO,DDGLCID,DDGLROW,DDGLCOL,DDGLHT,DDGLWD,DDGLSEL,DDGLMAP) ; ;Create a list box window ;Out: ; .DDGLCID array = properties of list box ; .DDGLCID(id,"SV") = cid^$Y^$X^NL^NC^LINE ; .DDGLCID(id,"ITEM",1..nl) = text of item n in display ; .DDGLCID(id,"GL") = DDGLGLO ; .DDGLCID(id,"KMAP","IN") ; .DDGLCID(id,"KMAP","OUT") ; .DDGLCID(id,"KMAP","KD") ; .DDGLCID(id,"KMAP","TO") ; Q:$G(DDGLGLO)="" N DDGLNL,DDGLNC,DDGLLINE,DDGLLAST,DDGLITEM D INIT D SETCID Q ; DESTROY(DDGLCID,DDGLFLG) ;Destroy the window and cleanup D DESTROY^DDGLIBW(DDGLCID) K DDGLCID(DDGLCID) D KILL^DDGLIB0($G(DDGLFLG)) Q ; READ(DDGLCID,DDGLOUT) ; N DDGLGLO,DDGLROW,DDGLCOL,DDGLNL,DDGLNC,DDGLLINE,DDGLSEL,DDGLITEM N DX,DY ; D SETPARM X DDGLZOSF("EOFF") W $P(DDGLVID,DDGLDEL,11) ; D ^DDGLBXA1 ; D SETCID W $P(DDGLVID,DDGLDEL,12) X DDGLZOSF("EON") Q ; UPDATE(DDGLCID,DDGLVAL) ; N DDGLGLO,DDGLROW,DDGLCOL,DDGLNL,DDGLNC,DDGLLINE,DDGLSEL,DDGLITEM N DDGLI,DDGLT,DX,DY ; D SETPARM ; ;Get closest match incl. or foll. DDGLVAL S DDGLSEL=$G(DDGLVAL) I $G(DDGLSEL)="" S DDGLSEL=$O(@DDGLGLO@("")) E I '$D(@DDGLGLO@(DDGLSEL)) S DDGLSEL=$O(@DDGLGLO@(DDGLSEL)) Q:DDGLSEL="" ; ;Check whether DDGLVAL is already on the screen I DDGLITEM(1)']]DDGLSEL,DDGLSEL']]DDGLITEM(DDGLNL) D . D CUP(DDGLLINE,1) . W $E(DDGLITEM(DDGLLINE),1,DDGLNC) . F DDGLLINE=1:1:DDGLNL Q:DDGLITEM(DDGLLINE)=DDGLSEL . D CUP(DDGLLINE,1) . W $P(DDGLVID,DDGLDEL,6)_$E(DDGLSEL,1,DDGLNC)_$P(DDGLVID,DDGLDEL,10) ; ;If not, adjust the array E D . S DDGLT=DDGLSEL . F DDGLI=1:1:DDGLNL D .. S DDGLITEM(DDGLI)=DDGLT .. S:DDGLT]"" DDGLT=$O(@DDGLGLO@(DDGLT)) . D DISP(DDGLSEL) ; D SETCID Q ; SETCID ;Set DDGLCID array K DDGLCID(DDGLCID) S DDGLCID(DDGLCID,"SV")=DDGLCID_U_DDGLROW_U_DDGLCOL_U_DDGLNL_U_DDGLNC_U_DDGLLINE M DDGLCID(DDGLCID,"ITEM")=DDGLITEM S DDGLCID(DDGLCID,"GL")=DDGLGLO M DDGLCID(DDGLCID,"KMAP")=DDGLKEY("KMAP") Q ; SETPARM ;Set parameters from DDGLCID array N DDGLI S DDGLGLO=DDGLCID(DDGLCID,"GL") ; K DDGLKEY("KMAP") M DDGLKEY("KMAP")=DDGLCID(DDGLCID,"KMAP") M DDGLITEM=DDGLCID(DDGLCID,"ITEM") ; S DDGLI=DDGLCID(DDGLCID,"SV") S DDGLROW=$P(DDGLI,U,2) S DDGLCOL=$P(DDGLI,U,3) S DDGLNL=$P(DDGLI,U,4) S DDGLNC=$P(DDGLI,U,5) S DDGLLINE=$P(DDGLI,U,6) S DDGLSEL=DDGLITEM(DDGLLINE) K DDGLCID(DDGLCID) Q ; INIT ;Create list box (window) and setup variables ;In: DDGLROW,DDGLCOL,DDGLHT,DDGLWD,DDGLSEL,DDGLGLO,DDGLMAP ;Returns: DDGLROW,DDGLCOL,DDGLHT,DDGLWD,DDGLIND ; DDGLCID,DDGLNL,DDGLNC,DDGLLINE,DDGLITEM,DDGLKEY("KMAP") ; N DDGLAREA,DDGLI,DDGLT D INIT^DDGLIB0() ; ;Check and default DDGLROW,DDGLCOL,DDGLHT,DDGLWD,DDGLIND I $G(DDGLROW,-1)<0 S DDGLROW=5 E I DDGLROW+3>IOSL S DDGLROW=IOSL-3 I $G(DDGLCOL,-1)<0 S DDGLCOL=5 E I DDGLCOL+5>IOM S DDGLCOL=IOM-5 ; S DDGLHT=$S($D(DDGLHT)[0:7,DDGLHT<3:3,1:DDGLHT) S:DDGLROW+DDGLHT+1>IOSL DDGLHT=IOSL-DDGLROW ; S DDGLWD=$S($D(DDGLWD)[0:14,DDGLWD<5:5,1:DDGLWD) S:DDGLCOL+DDGLWD+1>IOM DDGLWD=IOM-DDGLCOL ; I $G(DDGLSEL)="" S DDGLSEL=$O(@DDGLGLO@("")) E I '$D(@DDGLGLO@(DDGLSEL)) S DDGLSEL=$O(@DDGLGLO@(DDGLSEL)) ; ;Initialize variables F DDGLI=1:1 Q:'$$EXIST^DDGLIBW("LBOX"_DDGLI) S DDGLCID="LBOX"_DDGLI S DDGLAREA=DDGLROW_U_DDGLCOL_U_DDGLHT_U_DDGLWD S DDGLNL=DDGLHT-2 S DDGLNC=DDGLWD-4 S DDGLLINE=1 ; ;Fill DDGLITEM array S DDGLT=DDGLSEL F DDGLI=1:1:DDGLNL D . S DDGLITEM(DDGLI)=DDGLT . S:DDGLT]"" DDGLT=$O(@DDGLGLO@(DDGLT)) ; ;Get key sequences, create window, display list D GETKEY D CREATE^DDGLIBW(DDGLCID,DDGLAREA,1) D DISP(DDGLSEL) Q ; DISP(DDGLSEL) ;Display the list ;In: DDGLSEL = text of selected item ; N DDGLI,DDGLT F DDGLI=1:1:DDGLNL D . D CUP(DDGLI,1) . S DDGLT=$E(DDGLITEM(DDGLI),1,DDGLNC) . S DDGLT=$S(DDGLT=DDGLSEL:$P(DDGLVID,DDGLDEL,6)_DDGLT_$P(DDGLVID,DDGLDEL,10),1:DDGLT)_$J("",DDGLNC-$L(DDGLT)) . W DDGLT Q ; CUP(Y,X) ;Position cursor relative to list coordinates S DY=DDGLROW+Y,DX=DDGLCOL+X+1 X IOXY Q ; GETKEY ;Get key sequences and defaults N AU,AD,AR,AL,F1,F2,F3,F4 N FIND,SELECT,INSERT,REMOVE,PREVSC,NEXTSC N I,K,N,T S AU=$P(DDGLKEY,U,2) S AD=$P(DDGLKEY,U,3) S AR=$P(DDGLKEY,U,4) S AL=$P(DDGLKEY,U,5) S F1=$P(DDGLKEY,U,6) S FIND=$P(DDGLKEY,U,10) S SELECT=$P(DDGLKEY,U,11) S PREVSC=$P(DDGLKEY,U,14) S NEXTSC=$P(DDGLKEY,U,15) ; S DDGLKEY("KMAP","IN")="",DDGLKEY("KMAP","OUT")="" ; I $D(DDGLMAP)>9 S I=0 F S I=$O(DDGLMAP(I)) Q:'I D . I $P(DDGLMAP(I),";",2)="KEYDOWN" S DDGLKEY("KMAP","KD")=$P(DDGLMAP(I),";") Q . I $P(DDGLMAP(I),";",2)="TIMEOUT" S DDGLKEY("KMAP","TO")=$P(DDGLMAP(I),";") Q . ; . S @("K="_$P(DDGLMAP(I),";",2)) . I DDGLKEY("KMAP","IN")'[(U_K),K]"" D .. S DDGLKEY("KMAP","IN")=DDGLKEY("KMAP","IN")_U_K .. S DDGLKEY("KMAP","OUT")=DDGLKEY("KMAP","OUT")_$P(DDGLMAP(I),";")_";" ; F I=1:1 S T=$P($T(MAP+I),";;",2,999) Q:T="" D . S @("K="_$P(T,";",2)) . I DDGLKEY("KMAP","IN")'[(U_K),K]"" D .. S DDGLKEY("KMAP","IN")=DDGLKEY("KMAP","IN")_U_K .. S DDGLKEY("KMAP","OUT")=DDGLKEY("KMAP","OUT")_$P(T,";")_";" S DDGLKEY("KMAP","IN")=DDGLKEY("KMAP","IN")_U S DDGLKEY("KMAP","OUT")=$E(DDGLKEY("KMAP","OUT"),1,$L(DDGLKEY("KMAP","OUT"))-1) Q ; MAP ;Keys for main screen ;;UP;AU ;;UP;AL ;;DN;AD ;;DN;AR ;;PUP;F1_AU ;;PUP;PREVSC ;;PDN;F1_AD ;;PDN;NEXTSC ;;TOP;F1_"T" ;;TOP;F1_F1_AU ;;TOP;FIND ;;BOT;F1_"B" ;;BOT;F1_F1_AD ;;BOT;SELECT ;;SEL;$C(13) ;;SEL;F1_"E" ;;QT;$C(27)_$C(27) ;;QT;F1_"Q" ;;QT;F1_"C" ;; DDGLBXA1^INT^1^60300,29508^0 DDGLBXA1 ;SFISC/MKO-SINGLE SELECTION LIST BOX ;11:33 AM 26 Apr 1996 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; N DDGLQT,Y D CUP(DDGLLINE,1) ; S DDGLQT=0 F S Y=$$READ D Q:DDGLQT . I Y'[U,$T(@Y)="" W $C(7) Q . D @Y . D:$G(DDGLKEY("KMAP","KD"))]"" @DDGLKEY("KMAP","KD") ; S:$P(DDGLQT,U,2,999)]"" DDGLOUT("C")=$P(DDGLQT,U,2,999) Q ; UP ;Move up I DDGLLINE>1 D . D CUP(DDGLLINE,1) . W $E(DDGLSEL,1,DDGLNC) . S DDGLLINE=DDGLLINE-1 . S DDGLSEL=DDGLITEM(DDGLLINE) . ; . D CUP(DDGLLINE,1) . W $P(DDGLVID,DDGLDEL,6)_$E(DDGLSEL,1,DDGLNC)_$P(DDGLVID,DDGLDEL,10) ; E D . N DDGLE . D SHIFTDN(1,.DDGLE) Q:$G(DDGLE) . S DDGLSEL=DDGLITEM(1) . D DISP(DDGLSEL) Q ; DN ;Move down I DDGLLINE1 D . D CUP(DDGLLINE,1) . W $E(DDGLSEL,1,DDGLNC) . S DDGLLINE=1,DDGLSEL=DDGLITEM(1) . D CUP(1,1) . W $P(DDGLVID,DDGLDEL,6)_$E(DDGLSEL,1,DDGLNC)_$P(DDGLVID,DDGLDEL,10) ; E D . N DDGLE . D SHIFTDN(DDGLNL,.DDGLE) Q:$G(DDGLE) . S DDGLSEL=DDGLITEM(1) . D DISP(DDGLSEL) Q ; PDN ;Page down in list I DDGLLINE1 PUP Q ; ;Fill DDGLITEM array S DDGLT=DDGLFRST F DDGLI=1:1:DDGLNL D . S DDGLITEM(DDGLI)=DDGLT . S:DDGLT]"" DDGLT=$O(@DDGLGLO@(DDGLT)) ; S DDGLLINE=1,DDGLSEL=DDGLITEM(1) D DISP(DDGLSEL) Q ; BOT ;Move to bottom of list N DDGLAST,DDGLI,DDGLT,DDGLIND ; ;Set DDGLIND = index of last non-null DDGLITEM F DDGLIND=DDGLNL:-1:1 Q:DDGLITEM(DDGLIND)]"" ; S DDGLAST=$O(@DDGLGLO@(""),-1) I DDGLAST=DDGLITEM(DDGLIND) D:DDGLLINEIOSL S DDGLROW=IOSL-4 I $G(DDGLCOL,-1)<0 S DDGLCOL=5 E I DDGLCOL+6>IOM S DDGLCOL=IOM-6 ; ;Check DDGLHT and DDGLWD S DDGLHT=$S($D(DDGLHT)[0:7,DDGLHT<3:3,1:DDGLHT) S:DDGLROW+DDGLHT+2>IOSL DDGLHT=IOSL-DDGLROW ; S DDGLWD=$S($D(DDGLWD)[0:14,DDGLWD<5:5,1:DDGLWD) S:DDGLCOL+DDGLWD+2>IOM DDGLWD=IOM-DDGLCOL ; S DDGLMAP(1)="LTAB^DDGLCBOX;$C(9)" S DDGLMAP(2)="LKDN^DDGLCBOX;KEYDOWN" ; D CREATE^DDGLBXA(DDGLGLO,.DDGLCBOX,DDGLROW+1,DDGLCOL+1,DDGLHT,DDGLWD,$G(DDGLSEL),.DDGLMAP) Q ; DDGLIB0^INT^1^61069,61055^0 DDGLIB0 ;SFISC/MKO-SETUP AND CLEANUP FOR WINDOWS ;3OCT2007 ;;22.0;VA FileMan;**1003,1004,1029** INIT() ;Setup required variables ;Set margin to 0 ;Turn autowrap off ;Turn type-ahead on ;Variables set: ; DDGLDEL = delimiter for other DDGL variables ; DDGLVID = codes that turn on/off video attributes ; DDGLED = codes for editing ; DDGLCLR = codes to erase characters ; DDGLGRA = codes for graphics characters ; DDGLZOSF = array of code from %ZOSF ; DDGLREF = global where window image is stored ; DDGLKEY = codes for non-alphanumeric keys ; DDGLSCR = array containing list of visible windows on screen ; N X I $D(DDGLDEL)[0 D SET Q:$G(DIERR) S X=0 X ^%ZOSF("RM"),^("TYPE-AHEAD") W $P(DDGLVID,DDGLDEL,8) Q ; SET ;Setup screen handling variables K DIERR,DDGLSCR S U="^",DDGLDEL=$C(127) ; F X="EOFF","EON","TRMOFF","TRMON","TRMRD" D G:$G(DIERR) ABT . I $D(^%ZOSF(X))#2 S DDGLZOSF(X)=^(X) Q . D BLD^DIALOG(810) ; ZIS N %ZIS,IOP S IOP="HOME" D ^%ZIS I POP D BLD^DIALOG(845) G ABT I $D(^%ZIS(2)),'$O(^%ZIS(2,+$G(IOST(0)),0)) D BLD^DIALOG(840,"#"_+$G(IOST(0))) G ABT ; D:$G(IOXY)="" TRMERR("Cursor positioning (XY CRT)") ; S X="IORVON;IORVOFF;IOELEOL;IOEDEOP;IOUON;IOUOFF;IOSGR0;IOINHI;IOINLOW;IOINORM;IOCUU;IOCUD;IOCUF;IOCUB;IODL;IOIL;IODCH;IOICH;IOEDALL;IOELALL;IORI;IOAWM1;IOAWM0;IOSTBM;IOPF1;IOPF2;IOPF3;IOPF4;IOFIND;IOSELECT;IOINSERT;IOREMOVE;IOPREVSC;IONEXTSC" N @$TR(X,";",",") N IOBLC,IOBRC,IOBT,IOG1,IOG0,IOHL,IOLT,IOMT,IORT,IOTLC,IOTRC,IOTT,IOVL D ENDR^%ZISS,GSET^%ZISS I $G(IOPREVSC)="" D ;"^C-VT220^C-VT320^"[(U_IOST_U) D IOST MIGHT BE VT-100 . S IOPREVSC=$C(27)_"[5~" . S IONEXTSC=$C(27)_"[6~" ; ATT ;tried: S IOINLOW=X_"32m" ;LOW = GREEN N A,B S A(1)=$C(27,91)_"40m",A(2)=$C(27,91)_"41m",A(3)=$C(27,91)_"45m" ;Defaults I $G(^XTV(8989.5,0))?1"PARAM".E F X=1,2,3 S A=$$GET^XPAR("ALL","DI SCREENMAN COLORS",X),B=$$GET^XPAR("ALL","DI SCREENMAN COLORS",X+3) S:B]"" A(X)=$C(27,91)_(10+B)_"m" S:A]"" A(X)=A(X)_$C(27,91)_+A_"m" S IOUON=IOINHI_A(1) ;REQ CAPTION BACKGROUND (BLACK) S IOINHI=IOINHI_A(2) ;DATA BACKGROUND (RED) S IORVON=IOINHI_A(3) ;CLICKABLE BACKGROUND (MAGENTA) S (IORVOFF,IOUOFF)=IOINORM S DDGLVID=IOINHI_DDGLDEL_IOINLOW_DDGLDEL_IOINORM_DDGLDEL_IOUON_DDGLDEL_IOUOFF_DDGLDEL_IORVON_DDGLDEL_IORVOFF_DDGLDEL_IOAWM0_DDGLDEL_IOAWM1_DDGLDEL_$G(IOSGR0) S DDGLED=$G(IORI)_DDGLDEL_$G(IOSTBM)_DDGLDEL_$G(IOIL)_DDGLDEL_$G(IODL)_DDGLDEL_$G(IOICH)_DDGLDEL_$G(IODCH) S DDGLCLR=IOELEOL_DDGLDEL_IOEDALL_DDGLDEL_IOEDEOP_DDGLDEL_$G(IOELALL) S DDGLKEY=U_IOCUU_U_IOCUD_U_IOCUF_U_IOCUB_U_IOPF1_U_IOPF2_U_IOPF3_U_IOPF4_U_$G(IOFIND)_U_$G(IOSELECT)_U_$G(IOINSERT)_U_$G(IOREMOVE)_U_$G(IOPREVSC)_U_$G(IONEXTSC)_U S DDGLGRA=IOG1_DDGLDEL_IOG0_DDGLDEL_IOHL_DDGLDEL_IOVL_DDGLDEL_IOTLC_DDGLDEL_IOTRC_DDGLDEL_IOBLC_DDGLDEL_IOBRC S:DDGLDEL_$P(DDGLGRA,DDGLDEL,3,999)_DDGLDEL[(DDGLDEL_DDGLDEL) DDGLGRA=DDGLDEL_DDGLDEL_"-"_DDGLDEL_"|"_DDGLDEL_"+"_DDGLDEL_"+"_DDGLDEL_"+"_DDGLDEL_"+" ; D:$P(DDGLKEY,U,1,5)_U[(U_U) TRMERR("Cursor keys") D:U_$P(DDGLKEY,U,6,9)_U[(U_U) TRMERR("PF keys") D:IOELEOL="" TRMERR("Erase to End of Line") D:IOEDALL="" TRMERR("Erase Entire Page") D:IOEDEOP="" TRMERR("Erase to End of Page") G:$G(DIERR) ABT ; S DDGLREF="^TMP(""DDGL"",$J,""W"")" K @DDGLREF ; I "^C-QUME^C-QVT102^C-WYSE75^"[(U_$TR(IOST," ","")_U) D . S DDGLVAN=1 . S $P(DDGLVID,DDGLDEL,4,7)=$S($TR(IOST," ","")="C-WYSE75":IOINHI_DDGLDEL_IOINLOW_DDGLDEL_IOINHI_DDGLDEL_IOINLOW,1:IOINLOW_DDGLDEL_IOINHI_DDGLDEL_IOINLOW_DDGLDEL_IOINHI) . S $P(DDGLVID,DDGLDEL,10)=IOINORM ; D:'$D(^%ZTSK)!($D(^%ZOSF("MGR"))[0) KILL^%ZISS MOUSEON ;I $G(DDS)>0 W *27,"[?1000h" NOW DONE IN DDS0 Q ; ; ASKIOSL ; not used ;N X ;X ^%ZOSF("EOFF") R X:0 S XX="" W $C(27)_7_$C(27)_"[r"_$C(27)_"[999;999H"_$C(27)_"[6n" R X ; R *X:1 R:$T XX S X=$C(X)_XX ;S X=+$E(X,3,5) I X S IOSL=X Q ; ; ; TRMERR(DDGLCH) ;Terminal type errors N P S P(1)=DDGLCH,P(2)=IOST D BLD^DIALOG(842,.P) Q ; ; ; KILL(DDGLPARM) ;Cleanup variables ;Set margin to IOM ;Turn off type-ahead if New Person file so indicates ;Turn autowrap on ;Reset character attributes ;Turn echo on ;Turn terminators off N X I $G(DDGLPARM)'["W" D . S X=$S($D(IOM)#2:IOM,1:80) X $G(^%ZOSF("RM")) . I $D(DUZ)#2,$D(^VA(200,DUZ,0))#2,$P($G(^(200)),U,9)'="Y" D .. I '$G(DUZ("BUF"),1) X $G(^%ZOSF("NO-TYPE-AHEAD")) . W $P($G(DDGLVID),$G(DDGLDEL),9),$P($G(DDGLVID),$G(DDGLDEL),10) ; I $G(DDGLPARM)'["T" D . X $G(DDGLZOSF("EON")),$G(DDGLZOSF("TRMOFF")) E X $G(DDGLZOSF("EOFF")),$G(DDGLZOSF("TRMON")) ; MOUSEOFF ;W *27,"[?1000l" NOW DONE IN DDS0 ABT K DX,DY,POP I '$G(DIERR),$G(DDGLPARM)["K" Q K:$G(DDGLREF)]"" @DDGLREF D:'$D(^%ZTSK)!($D(^%ZOSF("MGR"))[0) KILL^%ZISS ; K DDGLDEL,DDGLVID,DDGLED,DDGLCLR,DDGLGRA,DDGLZOSF,DDGLREF K DDGLKEY,DDGLSCR,DDGLVAN,DDGLH ; K DIR0 DDGLIBH^INT^1^60300,29509^0 DDGLIBH ;SFISC/MKO-SCREEN EDITOR HELP ;08:00 AM 23 Feb 1995 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; HLP(DDGLHN1,DDGLHN2,DDGLSUB,DDGLPLN) ; ;DDGLHN1 = Entry number in Dialog file of first help screen ;DDGLHN2 = Entry number of last help screen ;DDGLSUB = Subscript in ^TMP to copy help to ;DDGLPLN = $Y to print prompt ; N DX,DY,DDGLI,DDGLJ,DDGLSC,DDGLTX,DDGLX,DIHELP,DDGL0 S DDGL0=$C(31) D:'$D(DDGLH) GETKEY I $D(IOTM)[0 N IOTM S IOTM=1 I $D(IOBM)[0 N IOBM S IOBM=IOSL I '$G(DDGLPLN) S DDGLPLN=IOBM-1 S DDGLSC=DDGLHN1 ; D DISP(DDGLHN1) ; F S DDGLX=$$READ D @DDGLX Q:DDGLX=U Q ; UP I DDGLSC>DDGLHN1 S DDGLSC=DDGLSC-1 D DISP(DDGLSC) Q ; DN I DDGLSC1:$C(13,10),1:"")_DDGLTX_$P(DDGLCLR,DDGLDEL) ; F DDGLI=DDGLI:1:IOBM-IOTM+1 W $C(13,10)_$P(DDGLCLR,DDGLDEL) Q ; READ() ; S DY=DDGLPLN,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)_"Press " W:DDGLSC>DDGLHN1 $P(DDGLVID,DDGLDEL)_""_$P(DDGLVID,DDGLDEL,10)_" for previous page, " W:DDGLSC"_$P(DDGLVID,DDGLDEL,10)_" for next page, " W $P(DDGLVID,DDGLDEL)_"P"_$P(DDGLVID,DDGLDEL,10)_" to print, " W $P(DDGLVID,DDGLDEL)_"^"_$P(DDGLVID,DDGLDEL,10)_" to exit: " D GETCH(DTIME,.DDGLX) S DY=DDGLPLN,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL) Q DDGLX ; GETCH(DTIME,Y) ;Out: Y = Mnemonic F D Q:Y'=-1 . R *Y:DTIME . I Y<0 S Y="TO" Q . D MNE(.Y) Q ; MNE(Y) ;Out: Y = Mnemonic, or -1 if invalid N S,F S S="",F=0 F D MNELOOP Q:F Q ; MNELOOP ;Read more S S=S_$C(Y) I DDGLH("IN")'[(DDGL0_S) D I Y=-1 D FLUSH Q . I $C(Y)'?1L S Y=-1 Q . S S=$E(S,1,$L(S)-1)_$C(Y-32) . S:DDGLH("IN")'[(DDGL0_S_DDGL0) Y=-1 ; I DDGLH("IN")[(DDGL0_S_DDGL0),S'=$C(27) D Q . S Y=$P(DDGLH("OUT"),DDGL0,$L($P(DDGLH("IN"),DDGL0_S_DDGL0),DDGL0)),F=1 ; R *Y:5 D:Y=-1 FLUSH Q ; FLUSH ; N DDGLZ S F=1 W $C(7) F R *DDGLZ:0 E Q Q ; GETKEY ;Get key sequences and defaults N AU,AD,F1,PREVSC,NEXTSC N I,K,N,T S AU=$P(DDGLKEY,U,2) S AD=$P(DDGLKEY,U,3) S F1=$P(DDGLKEY,U,6) S PREVSC=$P(DDGLKEY,U,14) S NEXTSC=$P(DDGLKEY,U,15) ; K DDGLH S DDGLH("IN")="",DDGLH("OUT")="" F I=1:1 S T=$P($T(MAP+I),";;",2,999) Q:T="" D . S @("K="_$P(T,";",2)) . I DDGLH("IN")'[(DDGL0_K),K]"" D .. S DDGLH("IN")=DDGLH("IN")_DDGL0_K .. S DDGLH("OUT")=DDGLH("OUT")_$P(T,";")_DDGL0 S DDGLH("IN")=DDGLH("IN")_DDGL0 S DDGLH("OUT")=$E(DDGLH("OUT"),1,$L(DDGLH("OUT"))-1) Q ; MAP ;Keys ;;DN;$C(13) ;;DN;AD ;;DN;F1_AD ;;DN;NEXTSC ;;UP;AU ;;UP;F1_AU ;;UP;PREVSC ;;QT;F1_"E" ;;QT;F1_"Q" ;;QT;"^" ;;PT;"P" DDGLIBW^INT^1^60300,29509^0 DDGLIBW ;SFISC/MKO-WINDOW PRIMITIVES ;02:24 PM 13 Jul 1994 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; ; Area is defined as $Y^$X^height^width ; DDGLREF(wid)=$Y^$X^height^width ; DDGLREF(wid,$Y+1,"TXT")=string ; DDGLREF(wid,$Y+1,"ATT")=attributes (bold,underline,reverse,graphic) ; ; DDGLSCR array - keeps track of what windows are on the screen and ; the order in which they overlap ; Form of DDGLSCR array: ; DDGLSCR = # of elements ; DDGLSCR(n) = wid ; DDGLSCR("B",wid,n)= "" ; CREATE(I,A,B,N) ; G CREATE1^DDGLIBW1 ; OPEN(I,N) ; G OPEN1^DDGLIBW1 ; FOCUS(I,N) ; G FOCUS1^DDGLIBW1 ; CLOSE(I,NC) ; G CLOSE1^DDGLIBW1 ; CLEAR(I,A) ; ;Clear area A in window I G CLEAR1^DDGLIBW1 ; EXIST(I) ; ;Does window I exist? Q $D(@DDGLREF@(I))#2 ; CLOSEALL(N) ; ;Close all windows W:'$G(N) $P(DDGLCLR,DDGLDEL,2) K DDGLSCR Q ; DESTROY(I,NC) ; ;Destroy window I D CLOSE(I,$G(NC)) K @DDGLREF@(I) Q ; DESTALL ;Destroy all windows K @DDGLREF,DDGLSCR Q ; WRITE(I,S,Y,X,A,N) ; ;Write str S in window I at $Y=R, $X=C, attr A ; If N=1, update buffer, but don't write N A1,A0,A9 Q:$G(S)="" S:$G(I)="" I=-1 S A9=$$AREA(I) Q:X'<$P(A9,U,4) Q:Y'<$P(A9,U,3) S S=$E(S,1,$P(A9,U,4)-X) ; S $E(@DDGLREF@(I,Y+1,"TXT"),X+1,X+$L(S))=S I $G(A)="",$D(@DDGLREF@(I,Y+1,"ATT"))#2 S $E(@DDGLREF@(I,Y+1,"ATT"),X+1,X+$L(S))=$J("",$L(S)) S:$G(A)]"" $E(@DDGLREF@(I,Y+1,"ATT"),X+1,X+$L(S))=$TR($J("",$L(S))," ",$$CODE(A,.A1,.A0)) ; I '$G(N) D . N DY,DX . S DY=Y+$P(A9,U),DX=X+$P(A9,U,2) X IOXY W $G(A1)_S_$G(A0) ; I $G(@DDGLREF@(I,Y+1,"TXT"))?." ",$G(@DDGLREF@(I,Y+1,"ATT"))?." " K @DDGLREF@(I,Y+1,"TXT"),@DDGLREF@(I,Y+1,"ATT") Q ; REPALL(A) ; ;Repaint absolute area A in all windows in DDGLSCR array N J I $G(A)="" D . W $P(DDGLCLR,DDGLDEL,2) . F J=1:1:$G(DDGLSCR) D REPAINT(DDGLSCR(J)) E D . D CLEAR(-1,A) . F J=1:1:$G(DDGLSCR) D REPAINT(DDGLSCR(J),$$RELAREA(DDGLSCR(J),A)) Q ; REPAINT(I,A) ; ;Repaint area A of window I N X,Y,H,W,R,C,T,X1,X2,A2,A1,A0,S,DY,DX,P I $D(A),A="" Q S:$G(I)="" I=-1 S:'$D(A) A="0^0^"_IOSL_U_IOM ; S A2=$$AREA(I) S A=$P(A,U)+$P(A2,U)_U_($P(A,U,2)+$P(A2,U,2))_U_$P(A,U,3,4) S A=$$INTSECT^DDGLIBW1(A,A2) S Y=$P(A,U)-$P(A2,U),X=$P(A,U,2)-$P(A2,U,2),H=$P(A,U,3),W=$P(A,U,4) ; I $D(@DDGLREF@(I))<9,Y+$P(A2,U)=0,X+$P(A2,U,2)=0,H=IOSL,W=IOM W $P(DDGLCLR,DDGLDEL,2) Q S P=IOM-X-$P(A2,U,2)-1_""" """ F R=Y+1:1:Y+H D . S S="" . S T=$E($G(@DDGLREF@(I,R,"TXT"))_$J("",X+W-$L($G(@DDGLREF@(I,R,"TXT")))),1,X+W) . S A=$E($G(@DDGLREF@(I,R,"ATT")),1,X+W) . S (X1,X2)=X+1 F D Q:$E(T,X2)="" .. S X1=X2,C=$E(A,X1) .. I C="" S X2=999 S S=S_$E(T,X1,X2) Q .. F X2=X1:1:$L(A)+1 Q:C'=$E(A,X2) .. D DECODE(C,.A1,.A0) .. S S=S_A1_$E(T,X1,X2-1)_A0 . S DY=R-1+$P(A2,U),DX=X+$P(A2,U,2) X IOXY . W $S(S?@P:$P(DDGLCLR,DDGLDEL),1:S) Q ; BOX(I,A,C,N) ; ;Draw a box in window I representing area A ;If C=1 writes spaces within the box ;If N=1 write to buffer but not screen N Y,X,H,W,L,R,S,A1 S:$G(I)="" I=-1 S:$G(A)="" A=$$AREA(I) S:$G(N)="" N=0 S A1=$$ABSAREA(I,A) S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4) Q:'H!'W S S=$J("",W-2),L=$TR(S," ",$P(DDGLGRA,DDGLDEL,3)) D WRITE(I,$P(DDGLGRA,DDGLDEL,5)_$S(W>1:L_$P(DDGLGRA,DDGLDEL,6),1:""),Y,X,"G",N) F R=Y+1:1:Y+H-2 D . D WRITE(I,$P(DDGLGRA,DDGLDEL,4),R,X,"G",N) . I W>1 D .. I $G(C) D WRITE(I,S,R,X+1,"",N) .. D WRITE(I,$P(DDGLGRA,DDGLDEL,4),R,X+W-1,"G",N) D:H>1 WRITE(I,$P(DDGLGRA,DDGLDEL,7)_$S(W>1:L_$P(DDGLGRA,DDGLDEL,8),1:""),Y+H-1,X,"G",N) Q ; ABSAREA(I,A) ; ;Given relative area A in window I, return absolute area N X,Y,H,W,X1,Y1 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4) S A=$$AREA(I) S Y1=Y+$P(A,U),X1=X+$P(A,U,2) S:Y1+H>IOSL H=IOSL-Y1 S:X1+W>IOM W=IOM-X1 Q Y1_U_X1_U_H_U_W ; RELAREA(I,A) ; ;Given absolute area A in window I, return relative area N X,Y,H,W,X1,Y1 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4) S A=$$AREA(I) S Y1=Y-$P(A,U),X1=X-$P(A,U,2) Q Y1_U_X1_U_H_U_W ; AREA(I) ;Return the coord and area of window I Q $S($D(@DDGLREF@(I))#2:@DDGLREF@(I),1:"0^0^"_IOSL_U_IOM) ; CODE(A,A1,A0) ; ;Return code char for selected attr N I,C,T S C=0,(A1,A0)="" S T=$TR(A,"burg","BURG") F I=1:1:$L(A) D . S T=$T(@$E(A,I)) . I T]"" D .. S C=C+$P(T,";",3) .. S A1=A1_$P(@$P(T,";",4),DDGLDEL,$P(T,";",5)) .. S A0=A0_$P(@$P(T,";",4),DDGLDEL,$P(T,";",6)) Q $C(C+32) ; DECODE(C,A1,A0) ; ;Given code char C, return codes to turn on/off attr N B,T S (A1,A0)="" Q:" "[$G(C) S C=$A(C)-32 S B=1 F D Q:B>8 . I C\B#2,$T(@B)]"" D .. S T=$T(@B+1) .. S A1=A1_$P(@$P(T,";",4),DDGLDEL,$P(T,";",5)) .. S A0=A0_$P(@$P(T,";",4),DDGLDEL,$P(T,";",6)) . S B=B*2 Q ; 1 ;; B ;;1;DDGLVID;1;2 2 ;; U ;;2;DDGLVID;4;5 4 ;; R ;;4;DDGLVID;6;7 8 ;; G ;;8;DDGLGRA;1;2 DDGLIBW1^INT^1^60300,29509^0 DDGLIBW1 ;SFISC/MKO-WINDOWING PRIMITIVES ;02:23 PM 13 Jul 1994 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. CREATE(I,A,B,N) ; CREATE1 ;Create window I of area A and draw border (if B) ;N = nn; first n=1 means don't give the window focus ; second n=1 means don't write to screen ; S:$G(I)="" I=-1 S:$G(A)="" A="0^0^"_IOSL_U_IOM K @DDGLREF@(I) S @DDGLREF@(I)=A D:$G(B) BOX^DDGLIBW(I,"0^0^"_$P(A,U,3,4),1,$G(N)) D:$G(N)<9 FOCUS(I,$G(N)!$G(B)) Q ; OPEN(I,N) ; OPEN1 ;Open window I G FOCUS1 ; FOCUS(I,N) ; FOCUS1 ;Give focus to window I ;If N=1; don't paint window Q:$D(@DDGLREF@(I))[0 Q:$G(DDGLSCR(+$G(DDGLSCR)))=I ; I '$D(DDGLSCR("B",I)) D . S DDGLSCR=$G(DDGLSCR)+1,DDGLSCR(DDGLSCR)=I,DDGLSCR("B",I,DDGLSCR)="" E D . N M,N . S DDGLSCR(DDGLSCR+1)=I . S M=$O(DDGLSCR("B",I,"")) . F N=M:1:DDGLSCR D .. K DDGLSCR("B",DDGLSCR(N),N) .. S DDGLSCR(N)=DDGLSCR(N+1) .. S DDGLSCR("B",DDGLSCR(N),N)="" . K DDGLSCR(DDGLSCR+1) D:'$G(N) REPAINT^DDGLIBW(I) Q ; CLOSE(I,NC) ; CLOSE1 ;Close window I N A,M,N,W S M=$O(DDGLSCR("B",I,"")) Q:M="" ; I '$G(NC) D . S A=$$AREA(I) . D CLEAR(I,"0^0^"_$P(A,U,3,4)) . F N=1:1:DDGLSCR D:N'=M .. S W=DDGLSCR(N) .. D REPAINT^DDGLIBW(W,$$RELAREA(W,$$INTSECT($$AREA(W),A))) ; F N=M:1:DDGLSCR-1 D . K DDGLSCR("B",DDGLSCR(N),N) . S DDGLSCR(N)=DDGLSCR(N+1) . S DDGLSCR("B",DDGLSCR(N),N)="" K DDGLSCR("B",DDGLSCR(DDGLSCR),DDGLSCR),DDGLSCR(DDGLSCR) S DDGLSCR=DDGLSCR-1 Q ; CLEAR(I,A) ; CLEAR1 ;Clear area A in window I N Y,X,H,W,S,DY,DX S:$G(I)="" I=-1 S:$G(A)="" A=$$AREA(I) S A=$$ABSAREA(I,A) S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4) I Y=0,X=0,H=IOSL,W=IOM W $P(DDGLCLR,DDGLDEL,2) Q S DX=X,S=$S(IOM-X=W:$P(DDGLCLR,DDGLDEL),1:$J("",W)) F DY=Y:1:Y+H-1 X IOXY W S Q ; ABSAREA(I,A) ; ;Given relative area A in window I, return absolute area N X,Y,H,W,X1,Y1 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4) S A=$$AREA(I) S Y1=Y+$P(A,U),X1=X+$P(A,U,2) S:Y1+H>IOSL H=IOSL-Y1 S:X1+W>IOM W=IOM-X1 Q Y1_U_X1_U_H_U_W ; RELAREA(I,A) ; ;Given absolute area A in window I, return relative area N X,Y,H,W,X1,Y1 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4) S A=$$AREA(I) S Y1=Y-$P(A,U),X1=X-$P(A,U,2) Q Y1_U_X1_U_H_U_W ; AREA(I) ;Return the coord and area of window I Q $S($D(@DDGLREF@(I))#2:@DDGLREF@(I),1:"0^0^"_IOSL_U_IOM) ; INTSECT(A1,A2) ; ;Return the intersection of areas 1 and 2 N A,X1,Y1,H1,W1,X2,Y2,H2,W2 S Y1=$P(A1,U),X1=$P(A1,U,2),H1=$P(A1,U,3),W1=$P(A1,U,4) S Y2=$P(A2,U),X2=$P(A2,U,2),H2=$P(A2,U,3),W2=$P(A2,U,4) S A="" S $P(A,U)=$$MAX(Y1,Y2),$P(A,U,2)=$$MAX(X1,X2) S $P(A,U,3)=$$LEN(Y1,H1,Y2,H2) S $P(A,U,4)=$$LEN(X1,W1,X2,W2) Q:'$P(A,U,3)!'$P(A,U,4) "" Q A ; MAX(X,Y) ; ;Return the max of X and Y Q $S(X>Y:X,1:Y) ; LEN(C1,L1,C2,L2) ; ;Return intersection length of two lines ; C = position along X or Y axis ; L = length of line Q:C1'>C2 $S(C1+L1'<(C2+L2):L2,C1+L1>C2:L1-C2+C1,1:0) Q $S(C2+L2'<(C1+L1):L1,C2+L2>C1:L2-C1+C2,1:0) DDIOL^INT^1^60300,29509^0 DDIOL ;SFISC/MKO-THE LOADER ;1:53 PM 12 Sep 1995 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; EN(A,G,FMT) ;Write the text contained in local array A or global array G ;If one string passed, use format FMT N %,Y,DINAKED S DINAKED=$$LGR^%ZOSV ; S:'$D(A) A="" I $G(A)="",$D(A)<9,$G(FMT)="",$G(G)'?1"^"1A.7AN,$G(G)'?1"^"1A.7AN1"(".E1")" Q ; G:$D(DDS) SM G:$D(DIQUIET) LD ; N F,I,S I $D(A)=1,$G(G)="" D . S F=$S($G(FMT)]"":FMT,1:"!") . W @F,A ; E I $D(A)>9 S I=0 F S I=$O(A(I)) Q:I'=+$P(I,"E") D . S F=$G(A(I,"F"),"!") S:F="" F="?0" . W @F,$G(A(I)) ; E S I=0 F S I=$O(@G@(I)) Q:I'=+$P(I,"E") D . S S=$G(@G@(I,0),$G(@G@(I))) . S F=$G(@G@(I,"F"),"!") S:F="" F="?0" . W @F,S ; I DINAKED]"" S DINAKED=$S(DINAKED["""""":$O(@DINAKED),1:$D(@DINAKED)) Q ; LD ;Load text into ^TMP N I,N,T S T=$S($G(DDIOLFLG)["H":"DIHELP",1:"DIMSG") S N=$O(^TMP(T,$J," "),-1) ; I $D(A)=1,$G(G)="" D . D LD1(A,$S($G(FMT)]"":FMT,1:"!")) ; E I $D(A)>9 S I=0 F S I=$O(A(I)) Q:I'=+$P(I,"E") D . D LD1($G(A(I)),$G(A(I,"F"),"!")) ; E S I=0 F S I=$O(@G@(I)) Q:I'=+$P(I,"E") D . D LD1($G(@G@(I),$G(@G@(I,0))),$G(@G@(I,"F"),"!")) ; K:'N @T S:N @T=N I DINAKED]"" S DINAKED=$S(DINAKED["""""":$O(@DINAKED),1:$D(@DINAKED)) Q ; LD1(S,F) ;Load string S, with format F ;In: N and T N C,J,L S:S[$C(7) S=$TR(S,$C(7),"") F J=1:1:$L(F,"!")-1 S N=N+1,^TMP(T,$J,N)="" S:'N N=1 S:F["?" @("C="_$P(F,"?",2)) S L=$G(^TMP(T,$J,N)) S ^TMP(T,$J,N)=L_$J("",$G(C)-$L(L))_S Q ; SM ;Print text in ScreenMan's Command Area I $D(DDSID),$D(DTOUT)!$D(DUOUT) G SMQ N DDIOL S DDIOL=1 ; I $D(A)=1&($G(G)="")!($D(A)>9) D . D MSG^DDSMSG(.A,"",$G(FMT)) E I $D(@G@(+$O(@G@(0)),0))#2 D . D WP^DDSMSG(G) E D HLP^DDSMSG(G) ; SMQ I DINAKED]"" S DINAKED=$S(DINAKED["""""":$O(@DINAKED),1:$D(@DINAKED)) Q DDMAP^INT^1^60300,29509^0 DDMAP ;SFISC/JKS(Helsinki)-GRAPH OF FILEMAN POINTER RELATIONS ;7/1/93 4:14 PM ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ;EXPLANATIONS: ; N = normal reference ; S = pointer file not included in the set ; C = cross reference in the pointer file ; L = laygo allowed ; * = reference internally truncated ; m = Multiple field ; v = Variable Pointer ; ST S DDPCK=1 I DUZ(0)'="@",$S($D(^VA(200,DUZ,"FOF",9.4,0)):1,1:$D(^DIC(3,DUZ,"FOF",9.4,0))) G INFO:$P(^(0),U,2),EN1 I DUZ(0)'="@",$D(^DIC(9.4,0,"DD")) S DDPCK=0 F I=1:1:$L(^("DD")) I DUZ(0)[$E(^("DD"),I) S DDPCK=1 Q I 'DDPCK G EN1 INFO W !!,"Prints a graph of pointer relations in a database of FileMan files",!,"named in the Kernel PACKAGE file (9.4) or given separately.",!,"Works best with 132 column output!" DDPCK D DT^DICRW K ^UTILITY($J),DDTO,DDPCK,DUOUT,DTOUT S DDPCKN="" G GET:'$D(^DD(9.4)) S DIC=9.4,DIC(0)="AEQML" D ^DIC G END:X[U!$D(DTOUT),GET:Y<0 S DDPCK=+Y,DDPCKN=$P(Y,U,2) S DDFLE="" F I=1:1 S DDFLE=$O(^DIC(9.4,DDPCK,4,"B",DDFLE)) Q:DDFLE="" S ^UTILITY($J,"F",DDFLE)="" G GET:DDPCKN="" D LIST REM S DIC=1,DIC(0)="AEMQ",DIC("S")="I $D(^UTILITY($J,""F"",+Y)) Q",DIC("A")="Remove FILE: " D ^DIC G:X[U!$D(DTOUT) END G:Y<0 ADD K ^UTILITY($J,"F",+Y) G REM GET I DDPCKN="" W !!,"Enter files to be included" ADD K DIC I DUZ(0)'="@" S DIC("S")="I 1 Q:'$D(^(0,""DD"")) F DC=1:1:$L(^(""DD"")) I DUZ(0)[$E(^(""DD""),DC) Q" D ADD0 S DIC=1,DIC(0)="QEAM",DIC("A")="Add FILE: " D ^DIC G END:X[U!$D(DTOUT),ADD1:Y<0 S ^UTILITY($J,"F",+Y)="" G ADD ADD0 I $D(^VA(200,"AFOF")) S DIC("S")="I $D(^VA(200,DUZ,""FOF"",+Y,0)),$P(^(0),U,2) Q" I $D(^DIC(3,"AFOF")) S DIC("S")="I $D(^DIC(3,DUZ,""FOF"",+Y,0)),$P(^(0),U,2) Q" Q ADD1 G END:'$D(^UTILITY($J)) D:DDPCKN="" LIST GO G END:'$D(^UTILITY($J)) W !,"Enter name of file group for optional graph header: " W:DDPCKN]"" DDPCKN,"// " R X:DTIME G:X[U!'$T END I X'[U,X]"",($L(X)<3!($L(X)>20)) W:X'["?" $C(7) G HLP1:X["?",HLP S:X="" X=DDPCKN S DDPCKN=X W ! EXIT S %ZIS="Q" D ^%ZIS G:POP EXIT1 S DDFLE=0 I $D(IO("Q")) S ZTRTN="NXF^DDMAP2" F I="^UTILITY($J,","DDFLE","DDPCKN" S ZTSAVE(I)="" I $D(IO("Q")) D ^%ZTLOAD G EXIT1 U IO G ^DDMAP2 EN1 W !," Access NOT Permitted for this Routine.",!,"(Must have DD Access to the PACKAGE File)" END K DIC,DDFLE,DDPCKN,DDPCK,^UTILITY($J) Q EXIT2 I $D(ZTSK) K ^%ZTSK(ZTSK),ZTSK G KILL EXIT1 I $D(DD9),IO=IO(0) R !,"Enter '^' to exit or return to continue: ",X:$S($D(DTIME):DTIME,1:300) I $T,X'=U D KILL W @IOF G ST KILL W:$Y @IOF X $G(^%ZIS("C")) K ^UTILITY($J),DDA1,DDA2,DDCR,DIC,DDFL,DDFLD,DDFLE,DDFNMAX,DDFRN,DDFPT,I,DDINC,DDLGO,DDLN,DDMAX,DDOUT,DD5,DD7,DD9,DDP,DDPCK,DDPCKN,DDPP K %H,%ZISI,%,DISYS,DDPT,DDPTF,DDTB1,DDTB2,DDTO,DDW,X,Y,%T,%XX,%YY,ZTSK,DDMIOSL,DDMAPC Q LIST W !!,"Files included" S DDFLE=0 F I=1:1 S DDFLE=$O(^UTILITY($J,"F",DDFLE)) Q:DDFLE'>0 W ?27,$J(DDFLE,10)," ",$O(^DD(DDFLE,0,"NM","")),! Q HLP1 W !,"Type a header that can be used for the print out" HLP W !,"The Header must be between 3 and 20 characters" G GO DDMAP1^INT^1^61069,61055^0 DDMAP1 ;SFISC/JKS(Helsinki)-GRAPH OF FILEMAN PTRS ;22MAY2007 ;;22.0;VA FileMan;**GFT,1028**;Mar 30, 1999 ; NXF S DDFLE=$O(^UTILITY($J,"FD",DDFLE)) G EXIT2^DDMAP:DDFLE'>0 S DDLN=1,DDOUT=0,DD9=0 I $Y>DDMIOSL D HDR^DDMAP2 G KILL^DDMAP:$D(DTOUT) D VIIVA^DDMAP2,TO S DDPCK=$$FILENAME^DIALOGZ(DDFLE) D FSHORT W ?DDTB1,"| ",DDFLE," ",DDPCK W ?DDTB2,"|",! S DDFL="" ;write File name and number in box I $Y>DDMIOSL D HDR^DDMAP2 G KILL^DDMAP:$D(DTOUT) NXFL S DDFL=$O(^UTILITY($J,"FD",DDFLE,"FR",DDFL)),DDFLD=0 I DDFL="" G END NXFLD S DDFLD=$O(^UTILITY($J,"FD",DDFLE,"FR",DDFL,DDFLD)),DDFPT=0,DD5=DDFL G:DDFLD'>0 NXFL S DDFRN=$$LABEL^DIALOGZ(DDFL,DDFLD) NXUP I $D(^DD(DD5,0,"UP")) S DD5=^("UP"),DD7=$$FILENAME^DIALOGZ(DD5) S:(DD5'=$P(DDFRN,":",1)) DDFRN=DD7_":"_DDFRN G NXUP NXPT S DDFPT=$O(^UTILITY($J,"FD",DDFLE,"FR",DDFL,DDFLD,DDFPT)) G NXFLD:DDFPT'>0 S DDA2=^(DDFPT) D TO REV S DDA1=$S($P(DDA2,U,2)["M":"m",1:""),DDA2=$S($P(DDA2,U,2)["V":"v",1:""),DDMAX=DDFNMAX,DDP=DDFRN D SHORT W ?DDTB1,"| " W:DDP]"" DDA2,DDA1,?DDTB1+4,DDP W ?DDTB2,"|" D OUT S DDFRN="" I $Y>DDMIOSL D HDR^DDMAP2 G KILL^DDMAP:$D(DTOUT) G NXPT FSHORT I DDFNMAX-$L(DDFLE)-$L(DDPCK)<0 S DDPCK=$E(DDPCK,1,DDFNMAX-$L(DDFLE)-1)_"*" Q SHORT Q:$L(DDP)'>DDMAX S DDPP=$L(DDP,":"),DD5=DDP I DDPP>1 S DD7=DDMAX-DDPP\DDPP,DD5=$E($P(DDP,":",1),1,DD7) F I=2:1:DDPP S DD5=DD5_":"_$E($P(DDP,":",I),1,DD7) S DDP=$E(DD5,1,DDMAX-1)_"*" Q OUT ; W "->",$P(DDFPT," ",2) W " " S DDP=$$FILENAME^DIALOGZ(DDFPT) S:DDP="" DDP="*** NONEXISTENT FILE "_DDFPT_"***" S DDMAX=IOM-$X D SHORT W DDP,! Q ; ; TO N DDLGO ;WRITE LEFT SIDE OF BOX S DDP="",(DDCR,DDINC)=0 Q:'$D(^UTILITY($J,"FD",DDFLE,"TO",DDLN)) S DDPT=$O(^(DDLN,"")),DDPTF=$O(^(DDPT,"")),DDA1=$$LABEL^DIALOGZ(DDPT,DDPTF)_U_$P(^DD(DDPT,DDPTF,0),U,2),DDLN=DDLN+1 I DDPT'>0 S DDP="*** NONEXISTENT FILE ***",DDTO="" G TOOK I '$D(^DD(DDPT)) S DDP="*** NONEXISTENT FILE "_DDPT_"***" G TOOK S DDPTF=+DDPTF,DDTO=DDPT,DDPP=$P(DDA1,U,1) TOUP S DD5=$$FILENAME^DIALOGZ(DDTO) I $D(^DD(DDTO,0,"UP")) S DDTO=^("UP") S:(DD5'=$P(DDPP,":",1)) DDPP=DD5_":"_DDPP G TOUP S DDINC=$D(^UTILITY($J,"F",DDTO)),DDLGO=$P(DDA1,U,2)'["'",DDA1=$P(DDA1,U,2)["V" S:(DD5'=$P(DDPP,":",1)) DDPP=DD5_":"_DDPP S DDCR=0,DD5="",DD7=DDPT,DDP=DDPP S:DD7?.E1"."2N DD7=+$P(DD7,".",1,$L(DD7,".")-1) F I=1:1 S DD5=$O(^DD(DD7,0,"IX",DD5)) Q:DD5="" I $D(^DD(DD7,0,"IX",DD5,DDPT,DDPTF)) S DDCR=1 TOOK Q:DDP="" S DDMAX=DDTB1-15,DD5=$P(DDP,":",1),DD7=DDP D D SHORT .I DD5=DD9 S DDP=" "_$P(DDP,":",2,999),DDPT="" Q .W " ",$S(IOST["C":$E(DD5,1,20),1:DD5)," (#",DDTO,")",?DDTB1,"|",?DDTB2,"|",! .S DDP=" "_$P(DD7,":",2,999),DD9=DD5,DDPT="" Q S DDW=$S('DDINC:"N S",1:"N") D .W " ",DDP," " W:DDA1 "v " D W ?DDTB1-12,"(",DDW," " S:'$D(DDLGO) DDLGO=0 W:DDCR "C " W:DDLGO "L" W ")->" ..F I=$L(DDP):1:DDTB1-18 W "." Q ; ; END I $D(^UTILITY($J,"FD",DDFLE,"TO",DDLN)) D TO W:$X'>DDTB1 ?DDTB1,"|" W ?DDTB2,"|",! S DDOUT=1 D:$Y>DDMIOSL HDR^DDMAP2 G KILL^DDMAP:$D(DTOUT),END I DDOUT S DDOUT=0 D VIIVA^DDMAP2 G NXF S DDPCK=+$O(^UTILITY($J,"FD",DDFLE)) I '$D(^DD(DDPCK,0,"UP")) D VIIVA^DDMAP2 G NXF Q DDMAP2^INT^1^60300,29509^0 DDMAP2 ;SFISC/JKS(Helsinki)-GRAPH OF FILEMAN PTRS ;2/4/91 3:38 PM ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. NXF ;Loop thru file selected and get to/from pointers F DDFLE=0:0 S DDFLE=$O(^UTILITY($J,"F",DDFLE)) G:DDFLE'>0 ST D GETTO,GETFR GETTO ;Look down "PT" X-ref to find files that point to me. F DDPT=0:0 S DDPT=$O(^DD(DDFLE,0,"PT",DDPT)) Q:DDPT'>0 F DDPTF=0:0 S DDPTF=$O(^DD(DDFLE,0,"PT",DDPT,DDPTF)) Q:DDPTF'>0 D NOT I DDW D NOT1 Q NOT1 S DDTO(DDFLE)=$S('$D(DDTO(DDFLE)):1,1:DDTO(DDFLE)+1) S ^UTILITY($J,"FD",DDFLE,"TO",DDTO(DDFLE),DDPT,DDPTF)=DDA1 Q NOT S DDW=0 I $D(^DD(DDPT,DDPTF,0)) S DDA1=$P(^(0),U,1,2),X=$P(DDA1,U,2) S:(X[("P"_DDFLE))!(X["V") DDW=1 Q Q GETFR S DDPTF=DDFLE ;Look at all fields (and subs) to find pointers to others. NXTF F DDPCK=0:0 S DDPCK=$O(^DD(DDPTF,DDPCK)) G:DDPCK'>0 SUB S DDA1=$P(^DD(DDPTF,DDPCK,0),U,1,2),DDA2=$P(DDA1,U,2) D SETF:DDA2?.E1"P"1N.E,SETV:DDA2["V" Q SUB F DDMAPC=0:0 S DDPTF=$O(^DD(DDPTF)) Q:'$D(^DD(DDPTF,0,"UP"))!(DDPTF'[DDFLE) D NXFLD Q NXFLD F DDPCK=0:0 S DDPCK=$O(^DD(DDPTF,DDPCK)) Q:DDPCK'>0 S DDA1=$P(^(DDPCK,0),U,1,2),DDA2=$P(DDA1,U,2) D SETF:DDA2?.E1"P"1N.E,SETV:DDA2["V" Q SETF S DDPT=+$P(DDA2,"P",2) S:DDPT ^UTILITY($J,"FD",DDFLE,"FR",DDPTF,DDPCK,DDPT)=DDA1 Q SETV F X=0:0 S X=$O(^DD(DDPTF,DDPCK,"V",X)) Q:X'>0 S DDPT=$P(^(X,0),U),^UTILITY($J,"FD",DDFLE,"FR",DDPTF,DDPCK,DDPT)=$P(DDA1,U,1)_U_"V"_DDPT Q ST S DD9=0,DDFLE="",DDTB1=IOM\2,DDTB2=$S(IOM/4>30:30,1:IOM\4)+DDTB1,DDFNMAX=DDTB2-DDTB1-5,DDMIOSL=IOSL-4 D HDR G KILL^DDMAP:$D(DTOUT),^DDMAP1 VIIVA S DD5=$S($X1 S DDMPSTAT("LIEN")=DDMPIENS(1) E S (DDMPSTAT("FIEN"),DDMPSTAT("LIEN"))=DDMPIENS(1) Q ; TOT(DDMPSTAT) ; S DDMPSTAT("TOT")=DDMPSTAT("TOT")+1 I '$D(ZTQUEUED) W "." E I DDMPSTAT("TOT")#10=0,$$S^%ZTLOAD D . S DDMPSTAT("ABORT")=2 . S ZTSTOP=1 Q ; RECERR ; N DDMPERLN,DDMPERR S DDMPSTAT("NG")=DDMPSTAT("NG")+1 D LDXTMP^DDMP2("Record #"_DDMPSTAT("TOT")_" Rejected:") D MSG^DIALOG("AEB",.DDMPERR,$S($D(IOM):IOM-5,1:75)) S DDMPERLN=0 F S DDMPERLN=$O(DDMPERR(DDMPERLN)) Q:'DDMPERLN D LDXTMP^DDMP2(" "_DDMPERR(DDMPERLN)) D CLEAN^DIEFU I DDMPSTAT("NG")'2:DDMPQ,1:"") . . . S DDMPIN=$P(DDMPIN,DDMPTVAL,2) . . . I DDMPIN=DDMPFMT("FDELIM") S DDMPIN="",DDMPVAL=DDMPTVAL Q . . . S DDMPIN=$P(DDMPIN,DDMPFMT("FDELIM"),2,99) . . . I DDMPIN="",DDMPI'=DDMPNDCT S DDMPHOLD=DDMPTVAL Q . . . S DDMPVAL=DDMPTVAL . E I $G(DDMPFMT("FDELIM"))'="" D . . S DDMPTVAL=$P(DDMPIN,DDMPFMT("FDELIM")) . . I $L(DDMPIN,DDMPFMT("FDELIM"))=2,$P(DDMPIN,DDMPFMT("FDELIM"),2)="" S DDMPIN="",DDMPVAL=$G(DDMPHOLD)_DDMPTVAL,DDMPHOLD="" Q . . S DDMPIN=$P(DDMPIN,DDMPFMT("FDELIM"),2,99) . . I $G(DDMPHOLD)]"" S DDMPVAL=DDMPHOLD_DDMPTVAL,DDMPHOLD="" Q . . I DDMPIN="",DDMPI'=DDMPNDCT S DDMPHOLD=DDMPTVAL Q . . S DDMPVAL=DDMPTVAL . E D . . N DDMPLEN,DDMPLAST . . I '$D(DDMPSQ(DDMPSQ+1)) D BLD^DIALOG(1862) Q . . S DDMPLEN=$P(DDMPSQ(DDMPSQ+1),"~",4) . . I $G(DDMPHOLD)]"" D . . . S DDMPVAL=DDMPHOLD_$E(DDMPIN,1,DDMPLEN-$L(DDMPHOLD)) . . . S DDMPIN=$E(DDMPIN,DDMPLEN-$L(DDMPHOLD)+1,255) . . . S DDMPHOLD="" . . E D . . . S DDMPTVAL=$E(DDMPIN,1,DDMPLEN) . . . S DDMPIN=$E(DDMPIN,DDMPLEN+1,255) . . . I DDMPIN="",DDMPI'=DDMPNDCT S DDMPHOLD=DDMPTVAL Q . . . S DDMPVAL=DDMPTVAL . . I $D(DDMPVAL) F S DDMPLAST=$L(DDMPVAL) Q:$E(DDMPVAL,DDMPLAST)'=" " S DDMPVAL=$E(DDMPVAL,1,DDMPLAST-1) . I $D(DDMPVAL) D K DDMPVAL . . S DDMPSQ=DDMPSQ+1 . . I '$D(DDMPSQ(DDMPSQ)) D BLD^DIALOG(1862) Q . . I $G(DDMPFMT("QUOTED"))="YES" S DDMPVAL=$TR(DDMPVAL,DDMPQ) . . D FDASET(DDMPVAL,DDMPSQ(DDMPSQ)) I $G(DDMPFMT("FIXED"))="YES" F DDMPSQ=DDMPSQ+1:1 Q:'$D(DDMPSQ(DDMPSQ)) S DDMPVAL="" D FDASET(DDMPVAL,DDMPSQ(DDMPSQ)) Q ; FDASET(DDMPVAL,DDMPSPEC) ; S ^TMP($J,"DDMPFDA",$P(DDMPSPEC,"~"),$P(DDMPSPEC,"~",2),$P(DDMPSPEC,"~",3))=DDMPVAL Q ; DDMP1^INT^1^60300,29509^0 DDMP1 ;SFISC/DPC-ASCII IMPORT UTIILTIES ;9/19/96 14:58 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. GETFMT(DDMPFMT) ; ; Sets up format info. ;DDMPFMT passed by reference. N DDMPFRMT I '($D(DDMPFMT)\10) D Q:'($D(DDMPFMT)\10) . D FIND^DIC(.44,"","1;5;8","X",DDMPFMT,"","","","","DDMPFRMT") . I 'DDMPFRMT("DILIST",0) D BLD^DIALOG(1820,DDMPFMT,DDMPFMT) Q . S DDMPFMT("IEN")=DDMPFRMT("DILIST",2,1) . S DDMPFMT("FDELIM")=DDMPFRMT("DILIST","ID",1,1) . S DDMPFMT("FIXED")=DDMPFRMT("DILIST","ID",1,5) . S DDMPFMT("QUOTED")=DDMPFRMT("DILIST","ID",1,8) S DDMPFMT("FDELIM")=$G(DDMPFMT("FDELIM")) I DDMPFMT("FDELIM") D . N DDMPI,DDMPPC,DDMPASCI S DDMPASCI="" . F DDMPI=1:1 S DDMPPC=$P(DDMPFMT("FDELIM"),",",DDMPI) Q:'DDMPPC S DDMPASCI=DDMPASCI_$C(DDMPPC) . S DDMPFMT("FDELIM")=DDMPASCI S DDMPFMT("QUOTED")=$G(DDMPFMT("QUOTED"),"NO") S DDMPFMT("FIXED")=$G(DDMPFMT("FIXED"),"NO") I ((DDMPFMT("FIXED")="YES")&(DDMPFMT("FDELIM")'=""))!((DDMPFMT("FIXED")'="YES")&(DDMPFMT("FDELIM")="")) D BLD^DIALOG(1821) Q ; GETSRC(DDMPFSRC) ; ;Moves data from source file into global. N DDMPIMWK K ^TMP($J,"DDMP") S DDMPIMWK=$$FTG^%ZISH(DDMPFSRC("PATH"),DDMPFSRC("FILE"),$NA(^TMP($J,"DDMP",0)),3) I 'DDMPIMWK D BLD^DIALOG(1810,DDMPFSRC("FILE"),DDMPFSRC("FILE")) Q I '$D(^TMP($J,"DDMP")) D BLD^DIALOG(1812,DDMPFSRC("FILE"),DDMPFSRC("FILE")) Q ; RQIDOK(DDMPFLDS) ; ;Verifies that required identifiers present in fields being imported. N DDMPF,DDMPRIDS,DDMPRID,DDMPERCT S DDMPF=0,DDMPERCT=$G(DIERR) F S DDMPF=$O(DDMPFLDS(DDMPF)) Q:DDMPF="" D . D REQIDS^DICU(DDMPF,"DDMPRIDS") . S DDMPRID=0 . F S DDMPRID=$O(DDMPRIDS("REQUIRED IDENTIFIERS",DDMPRID)) Q:DDMPRID="" D . . I ";"_DDMPFLDS(DDMPF)_";"'[(";"_DDMPRID_";"),";"_DDMPFLDS(DDMPF)'[(";"_DDMPRID_"[") D . . . N DDMPP S DDMPP("FILE")=DDMPF . . . D BLD^DIALOG(312,.DDMPP,.DDMPP) Q DDMPERCT=$G(DIERR) ; INFILE(DDMPINAR,DDMPFMT,DDMPFBCK,DDMPDR,DDMPNCNT) ; N DDMPDELM,DDMPFLDS,DDMPF,DDMPFSTR,DDMPI,DDMPJ,DDMPVAL,DDMPDONE S DDMPNCNT="" I DDMPFMT("FIXED")="YES" S DDMPDELM="," E S DDMPDELM=DDMPFMT("FDELIM") F S DDMPNCNT=$O(@DDMPINAR@(DDMPNCNT)) Q:DDMPNCNT=""!$G(DDMPDONE) S DDMPVAL=^(DDMPNCNT) D Q:$G(DIERR) . I DDMPVAL="" Q . I '$D(DDMPF) D Q . . S DDMPF=$P(DDMPVAL,"FILE=",2) . . I DDMPF="" D BLD^DIALOG(1831) Q . . S DDMPF=$$FILENUM(DDMPF) . F DDMPI=1:1 S DDMPFSTR=$P(DDMPVAL,DDMPDELM,DDMPI) Q:DDMPFSTR="" D . . N DDMPFDF,DDMPDPTH,DDMPFLD . . S DDMPDPTH=$L(DDMPFSTR,":") . . S DDMPFDF=DDMPF . . F DDMPJ=1:1:DDMPDPTH S DDMPFLD=$P(DDMPFSTR,":",DDMPJ) D Q:$G(DIERR) . . . N DDMP0P2 . . . D FLDVAL Q:$G(DIERR) . . . S $P(DDMPFSTR,":",DDMPJ)=DDMPFLD_U_DDMPFDF . . . S DDMPFDF=+DDMP0P2 . . S DDMPFLDS(DDMPI)=DDMPFSTR . S DDMPDONE=1 I $O(@DDMPINAR@(DDMPNCNT))="" S DDMPNCNT="" I $G(DIERR)!(DDMPNCNT="") Q S DDMPFLDS=1 D TODR(DDMPF,.DDMPFLDS,.DDMPDR) S DDMPFBCK=DDMPF Q ; FILENUM(DDMPF) ; I DDMPF,$$VFILE^DILFD(DDMPF) Q DDMPF I $D(^DIC("B",DDMPF))=10 Q $O(^(DDMPF,"")) D BLD^DIALOG(409,DDMPF,DDMPF) Q 0 FLDVAL ; N DDMP0 I 'DDMPFLD S DDMPFLD=$$FLDNUM^DILFD(DDMPFDF,DDMPFLD) Q:$G(DIERR) S DDMP0=$G(^DD(DDMPFDF,DDMPFLD,0)) I DDMP0="" D Q . N DDMPP S DDMPP("FILE")=DDMPFDF,DDMPP(1)=DDMPFLD . D BLD^DIALOG(501,.DDMPP,.DDMPP) S DDMP0P2=$P(DDMP0,U,2) I 'DDMP0P2 D . I DDMPJ1,$P($P(DDMPFLDS(DDMPI-1),":",DDMPJ-1),U,2)'=$P($P(DDMPFSTR,":",DDMPJ-1),U,2) D . D BLD^DIALOG(1844) Q ; TMPL2DR(DDMPF,DDMPFLDS) ; N DDMPDR N DDMPERR S DDMPERR=$G(DIERR) D TMPL2SQ(DDMPF,.DDMPFLDS) I DDMPERR'=$G(DIERR) Q S DDMPFLDS=1 D TODR(DDMPF,.DDMPFLDS,.DDMPDR) K DDMPFLDS M DDMPFLDS=DDMPDR Q ; TMPL2SQ(DDMPF,DDMPFLSQ) ; N DDMPTPNM,DDMPTPNO,DDMPSQ,DDMPPATH S DDMPTPNM=$S($E(DDMPFLSQ)="[":$P($P(DDMPFLSQ,"[",2),"]"),1:DDMPFLSQ) S DDMPTPNO=$O(^DIST(.46,"F"_DDMPF,DDMPTPNM,"")) I 'DDMPTPNO D Q ;Template does not exist. . N DDMPARAM . S DDMPARAM(1)=DDMPTPNM,DDMPARAM("FILE")=DDMPF . D BLD^DIALOG(1870,.DDMPARAM,.DDMPARAM) D LIST^DIC(.463,","_DDMPTPNO_",","1;2;3;10","I") I '$D(^TMP("DILIST",$J,0)) Q F DDMPSQ=1:1:+^TMP("DILIST",$J,0) D . S DDMPPATH=^TMP("DILIST",$J,"ID",DDMPSQ,10) . S DDMPFLSQ(DDMPSQ)=$S(DDMPPATH]"":DDMPPATH_":",1:"")_^(2)_U_^(1) ;naked set on prior line. . I ^(3) S DDMPFLSQ("LN",DDMPSQ)=^(3) ;naked set 2 lines above. K ^TMP("DILIST",$J) Q ; TODR(DDMPF,DDMPFLDS,DDMPDR,DDMPDRTP) ; N DDMPPPTH,DDMPCPTH,DDMPDPTH,DDMPFDWN,DDMPDONE,DDMPODTH F D Q:$G(DDMPDONE)!$G(DIERR) . I '$D(DDMPFLDS(DDMPFLDS)) D TMP2DR Q . I '$D(DDMPDPTH) S DDMPODTH=$L(DDMPFLDS(DDMPFLDS),":") . S DDMPDPTH=$L(DDMPFLDS(DDMPFLDS),":") . I '$D(DDMPCPTH) S DDMPPPTH=$P(DDMPFLDS(DDMPFLDS),":",1,DDMPDPTH-1) . S DDMPCPTH=$P(DDMPFLDS(DDMPFLDS),":",1,DDMPDPTH-1) . I DDMPCPTH=DDMPPPTH D . . I $G(DDMPDRTP(DDMPF))[(";"_+$P(DDMPFLDS(DDMPFLDS),":",DDMPDPTH)_";") D Q . . . I +$P(DDMPFLDS(DDMPFLDS),":",DDMPDPTH)=$P(DDMPDRTP(DDMPF),";",2),DDMPDPTH>1 D . . . . D TMP2DR . . . E D BLD^DIALOG(1845) . . S DDMPDRTP(DDMPF)=$G(DDMPDRTP(DDMPF),";")_+$P(DDMPFLDS(DDMPFLDS),":",DDMPDPTH)_$S('$D(DDMPFLDS("LN")):"",1:"["_DDMPFLDS("LN",DDMPFLDS)_"]")_";" . . S DDMPFLDS=DDMPFLDS+1 . . S DDMPPPTH=DDMPCPTH . . S DDMPODTH=DDMPDPTH . E I DDMPDPTH'>DDMPODTH D . . D TMP2DR . E D . . S DDMPDRTP(DDMPF)=DDMPDRTP(DDMPF)_+$P(DDMPFLDS(DDMPFLDS),":",DDMPDPTH-1)_";" . . S DDMPFDWN=$P($P(DDMPFLDS(DDMPFLDS),":",DDMPDPTH),U,2) . . D TODR(DDMPFDWN,.DDMPFLDS,.DDMPDR,.DDMPDRTP) Q ; TMP2DR ; S DDMPDONE=1 I '$D(DDMPDR(DDMPF)) S DDMPDR(DDMPF)=$E(DDMPDRTP(DDMPF),2,$L(DDMPDRTP(DDMPF))-1) E I DDMPDR(DDMPF)'=$E(DDMPDRTP(DDMPF),2,$L(DDMPDRTP(DDMPF))-1) D . D BLD^DIALOG(1846,DDMPF,DDMPF) K DDMPDRTP(DDMPF) Q ; DDMP2^INT^1^60300,29509^0 DDMP2 ;SFISC/DPC-Import Device, Queuing, Reports ;11/5/97 08:10 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. DEV(DDMPIOIN,DDMPIOP) ; ;Device selection for printed report. ;DDMPIOIN might contain preselected info. ;DDMPIOP will contain device data for later use with ^%ZIS. I $D(DDMPIOIN("IOP")) D . I $P(DDMPIOIN("IOP"),";")'="Q" S DDMPIOP=DDMPIOIN("IOP") . E D . . S DDMPIOP=$P(DDMPIOIN("IOP"),";",2,99),DDMPIOP("Q")=1 . . I $D(DDMPIOIN("QTIME")) D SETQTIME E D . N %ZIS,POP . S %ZIS="QN" . S %ZIS("A")="Device for Import Results Report: " . D ^%ZIS . I POP S DDMPIOP("NG")=1 Q . I $E(IOST,1,2)="C-" S DDMPIOP("HOME")=1 Q . D SETIOP . I $G(IO("Q")) S DDMPIOP("Q")=1 Q . D HOME^%ZIS . I $P(DDMPIOP,";",2)="P-BROWSER" Q . N DIR,DIRUT,Y . S DIR(0)="Y" . S DIR("A")="Do you want to queue this data import" . D ^DIR . I $G(DIRUT) S DDMPIOP("NG")=1 Q . I Y S DDMPIOP("Q")=1 Q ; SETIOP ; ;Sets up IOP, etc., from variables returned by ^%ZIS. S DDMPIOP=ION I $G(IOST)]"" S DDMPIOP=DDMPIOP_";"_IOST I $G(IO("DOC"))]"" S DDMPIOP=DDMPIOP_";"_IO("DOC") Q I $G(IOM) S DDMPIOP=DDMPIOP_";"_IOM I $G(IOSL) S DDMPIOP=DDMPIOP_";"_IOSL I $G(IOT)="HFS" S DDMPIOP("HFSNAME")=IO,DDMPIOP("HFSMODE")="W" Q ; SETQTIME ; ;Sets time for queuing from value passed in ("QTIME") N X,Y,%DT S X=DDMPIOIN("QTIME") I X="NOW" S DDMPIOP("QTIME")=$H E D . I X'["@" S X="T@"_X . S %DT="XT",%DT(0)="NOW" . D ^%DT . I Y<0 S DDMPIOP("NG")=1 Q . S DDMPIOP("QTIME")=Y Q ; QUE(DDMPIOP) ; ;Queues the import. S ZTRTN="TASK^DDMP" S ZTIO="" S ZTDESC="Queued data import." I $D(DDMPIOP("QTIME")) S ZTDTH=DDMPIOP("QTIME") S ZTSAVE("^TMP($J,""DDMP"",")="" S ZTSAVE("DDMPIOP(")="" S ZTSAVE("DDMPIOP")="" S ZTSAVE("DDMPF")="" S ZTSAVE("DDMPSQ(")="" S ZTSAVE("DDMPFMT(")="" S ZTSAVE("DDMPFLG")="" S ZTSAVE("DDMPFLG(")="" S ZTSAVE("DDMPNCNT")="" S ZTSAVE("DDMPFSRC(")="" D ^%ZTLOAD I $G(ZTSK) D . W !,"Import queued. Task number: "_ZTSK E W !,"Queuing of import failed. Import aborted." Q ; REP1(DDMPRPSB,DDMPLN) ; N DDMPI,DDMPTXT,DDMPUSR,DDMPFNO,DDMPLEN S DDMPLN=0 I '$D(^XTMP("DDMP1000")) S DDMPRPSB="DDMP1000" E S DDMPRPSB="DDMP"_($P($O(^XTMP("DDMPz"),-1),"DDMP",2)+1) S ^XTMP(DDMPRPSB,0)=DT_U_DT_U S DDMPUSR=$$GET1^DIQ(200,DUZ_",",.01) S ^(0)=^XTMP(DDMPRPSB,0)_"Import report: "_DDMPUSR D LDXTMP($P($T(LN1+1),";;",2)_$P(DDMPUSR,",",2)_" "_$P(DDMPUSR,",")) D LDXTMP("") D LDXTMP($P($T(LN1+2),";;",2)_DDMPFSRC("PATH")_DDMPFSRC("FILE")) D LDXTMP($P($T(LN1+3),";;",2)_DDMPFMT("FIXED")) D LDXTMP($P($T(LN1+4),";;",2)_DDMPFMT("FDELIM")) D LDXTMP($P($T(LN1+5),";;",2)_DDMPFMT("QUOTED")) D LDXTMP($P($T(LN1+6),";;",2)_$S(DDMPFLG["E":"External",1:"Internal")) D LDXTMP("") D LDXTMP($P($T(LN1+7),";;",2)_$$GET1^DID(DDMPF,"","","NAME")) D LDXTMP("") D LDXTMP($P($T(LN1+8),";;",2)) D LDXTMP($P($T(LN1+9),";;",2)) F DDMPI=1:1 Q:'$D(DDMPSQ(DDMPI)) D . S DDMPFNO=$P(DDMPSQ(DDMPI),"~"),DDMPLEN=$P(DDMPSQ(DDMPI),"~",4) . S DDMPTXT=DDMPI_$J("",5-$L(DDMPI))_$S(DDMPLEN:DDMPLEN,1:"n/a") . S DDMPTXT=DDMPTXT_$J("",10-$L(DDMPTXT))_$$GET1^DID(DDMPFNO,$P(DDMPSQ(DDMPI),"~",3),"","LABEL") . I DDMPF'=DDMPFNO S DDMPTXT=DDMPTXT_$J("",43-$L(DDMPTXT))_$O(^DD(DDMPFNO,0,"NM","")) . D LDXTMP(DDMPTXT) D LDXTMP("") D LDXTMP("") D LDXTMP($P($T(LN1+10),";;",2)) D LDXTMP($P($T(LN1+11),";;",2)) D LDXTMP("") Q ; LDXTMP(DDMPTXT) ; S DDMPLN=DDMPLN+1 S ^XTMP(DDMPRPSB,DDMPLN)=DDMPTXT Q ; LN1 ; ;; Import Initiated By: ;; Source File: ;; Fixed Length: ;; Delimited By: ;; Text Values Quoted: ;; Values Are: ;; Primary FileMan Destination File: ;;Seq Len Field Name Subfile Name (if applicable) ;;--- --- ---------- ---------------------------- ;; Error Report ;; ------------ ; REP2(DDMPRPSB,DDMPLN,DDMPSTAT) ; N POP I '$G(DDMPSTAT("NG")) D LDXTMP($P($T(LN2+1),";;",2)) D LDXTMP("") D LDXTMP("") D LDXTMP($P($T(LN2+2),";;",2)) D LDXTMP($P($T(LN2+3),";;",2)) D LDXTMP("") I $G(DDMPSTAT("ABORT")) D . D LDXTMP($P($T(LN2+4),";;",2)) . D LDXTMP($P($T(LN2+(4+DDMPSTAT("ABORT"))),";;",2)) . D LDXTMP("") D LDXTMP($P($T(LN2+7),";;",2)_DDMPSTAT("TOT")) D LDXTMP($P($T(LN2+8),";;",2)_(DDMPSTAT("TOT")-DDMPSTAT("NG"))) D LDXTMP($P($T(LN2+9),";;",2)_DDMPSTAT("NG")) D LDXTMP("") D LDXTMP($P($T(LN2+10),";;",2)_$G(DDMPSTAT("FIEN"),"Nothing filed")) D LDXTMP($P($T(LN2+11),";;",2)_$G(DDMPSTAT("LIEN"),"Nothing filed")) D LDXTMP("") D LDXTMP($P($T(LN2+12),";;",2)_$$HTE^DILIBF(DDMPSTAT("BEG"))) S DDMPSTAT("END")=$H D LDXTMP($P($T(LN2+13),";;",2)_$$HTE^DILIBF(DDMPSTAT("END"))) D LDXTMP($P($T(LN2+14),";;",2)_$$HDIFF^DILIBF(DDMPSTAT("END"),DDMPSTAT("BEG"),3)) I $G(DDMPIOP("HOME")) W @IOF D PRNTHM Q I $P($G(DDMPIOP),";",2)="P-BROWSER" D BROWSET Q:POP D PRNTHM Q ;Set up queued job for report printing. N %ZIS S %ZIS="Q" S IOP="Q;"_DDMPIOP I $D(DDMPIOP("HFSNAME")) S %ZIS("HFSNAME")=DDMPIOP("HFSNAME") I $D(DDMPIOP("HFSNODE")) S %ZIS("HFSMODE")=DDMPIOP("HFSMODE") D ^%ZIS I POP Q ;ERROR THAT REPORT CANNOT PRINT K ZTIO S ZTRTN="PRNT^DDMP2" S ZTSAVE("DDMPRPSB")="" S ZTDTH=$H S ZTDESC="Printing of Import Log for User# "_DUZ D ^%ZTLOAD I '$D(ZTQUEUED) W !,"Task Number for printing: "_ZTSK Q PRNT ; ;Tasked print of report. S ZTREQ="@" U IO PRNTHM ;Print to home device. Tasked prints fall through. N DDMPCNT,DDMPPG,DDMPIOSL,DDMPOUT S DDMPIOSL=$G(IOSL,60) S DDMPPG=0,DDMPCNT=0 D HDR F S DDMPCNT=$O(^XTMP(DDMPRPSB,DDMPCNT)) Q:DDMPCNT="" D Q:$G(DDMPOUT) . W !,^XTMP(DDMPRPSB,DDMPCNT) . I $Y+3>DDMPIOSL D HDR I $E(IOST,1,2)'="C-" W @IOF D ^%ZISC Q ; BROWSET ; N %ZIS S IOP=DDMPIOP D ^%ZIS U IO Q ; HDR ; I DDMPPG,$E(IOST,1,2)="C-" N DIR,Y S DIR(0)="E" D ^DIR I 'Y S DDMPOUT=1 Q I DDMPPG W @IOF S DDMPPG=DDMPPG+1 W $P($T(HDR1+1),";;",2)_DDMPPG W !,$P($T(HDR1+2),";;",2) W ! Q ; HDR1 ; ;; Log for VA FileMan Data Import Page ;; ============================== LN2 ; ;; No errors occured during this data import. ;; Summary of Import ;; ----------------- ;; <<>> ;; USER ABORT OF TASKED IMPORT>>> ;; Total Records Read: ;; Total Records Filed: ;; Total Records Rejected: ;; IEN of First Record Filed: ;; IEN of Last Record Filed: ;; Import Filing Started: ;; Import Filing Completed: ;; Time of Import Filing: DDMPSM^INT^1^60300,29509^0 DDMPSM ;SFISC/DPC-IMPORT SCREENMAN CALLS ;9/20/96 10:07 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. FILESEL ; ; Called form Post-actin on change of Primary File prompt D PUT^DDSVALF("TMP_NM",1,1,"") I DDSOLD'="",$D(DDMPFDSL) S DDMPOLDF=DDSOLD,DDSBR="3^1^3" E D . K DDMPCPNM,DDMPCPTH,DDMPFCAP,DDMPCF,DDMPFDNM . S DDMPF=X . S DDMPFLNM=DDSEXT . D UNED^DDSUTL("FLD_JUMP",1,1,$S(X:0,1:1)) . D UNED^DDSUTL("TMP_NM",1,1,$S(X:0,1:1)) . D REFRESH^DDSUTL Q ; TMPLSCR(DDMPSELF,DDSEXT,DUZ) ; ;called from TMP_NM field. ;DDMPSELF = currently selected primary file. ;DDMPEXT = External value of selected template. I $P(^(0),U,4)'=DDMPSELF Q 0 I DUZ(0)["@" Q 1 N DDMPRDAC,DDMPI,DDMPOK S DDMPRDAC=$P(^(0),U,3),DDMPOK=0 F DDMPI=1:1:$L(DDMPRDAC) I DUZ(0)[$E(DDMPRDAC,DDMPI) S DDMPOK=1 Q Q DDMPOK ; CHNGFILE ; ;Called for Post-action on pop-up file change verification page. I X D ;code for changing selected file. . K DDMPFDSL,DDMPCPNM,DDMPCPTH,DDMPFCAP,DDMPCF,DDMPFDNM . S (DDMPOSET,DDMPFDCT)=0 . S DDMPF=$$GET^DDSVALF("F_SEL",1,1) . S DDMPFLNM=$$GET^DDSVALF("F_SEL",1,1,"E") . I DDMPF="" D UNED^DDSUTL("FLD_JUMP",1,1,1),UNED^DDSUTL("TMP_NM",1,1,1) . S DDSBR="FLD_JUMP^1^1" . ;D REFRESH^DDSUTL E D . D PUT^DDSVALF("F_SEL",1,1,DDMPOLDF,"I") . S DDSBR="F_SEL^1^1" Q ; IXF ; ;Called from input transform of Field Selection field. N D0,DA,DIC,DP,Y S DIC="^DD("_DDMPCF_",",DIC(0)="ENZ" D ^DIC I Y'>0 K X E S (X,DDMPX)=+$P(Y,"E"),DDMPFDNM=Y(0,0) Q ; FDPROC ; ;Called from post-action on change of Field Selection prompt. N DDMP0P2 S DDMP0P2=$P(^DD(DDMPCF,DDMPX,0),U,2) I +DDMP0P2 D . S DDSBR="FLD" . I 'DDMPFDCT D HLP^DDSUTL($C(7)_"You must select a field in the top level file before entering multiple.") Q . N DDMPI,DDMPOK . F DDMPI=1:1:DDMPFDCT I $P(DDMPFDSL(DDMPI),U,$L(DDMPFDSL(DDMPI),U))=DDMPCF S DDMPOK=1 Q . I '$G(DDMPOK) D HLP^DDSUTL($C(7)_"You must select a field in a subfile before entering one of its multiples.") Q . S DDMPFCAP=$$PATHNM(+DDMP0P2,DDMPFLNM) . S DDMPCPTH=$S($L($G(DDMPCPTH)):DDMPCPTH_":",1:"")_DDMPX_U_DDMPCF . S DDMPCF=+DDMP0P2 . S DDMPCPNM=$S($L($G(DDMPCPNM)):DDMPCPNM_":",1:"")_DDMPFDNM E D . S DDMPFDCT=DDMPFDCT+1 . S DDMPFDSL(DDMPFDCT)=$S($L($G(DDMPCPTH)):DDMPCPTH_":",1:"")_DDMPX_U_DDMPCF . S DDMPFDSL("CAP",DDMPFDCT)=$S($L($G(DDMPCPNM)):DDMPCPNM_":",1:"")_DDMPFDNM . S DDMPOSET=$S(DDMPFDCT>9:DDMPFDCT-9,1:0) . S DDSBR=$S($G(DDMPSMFF("FIXED"))="YES":"LEN",1:"FLD") Q ; PATHNM(DDMPSFNO,DDMPFLNM) ; N DDMPPATH S DDMPPATH="" I $D(^DD(DDMPSFNO,0,"UP")) F D Q:'$D(^DD(DDMPSFNO,0,"UP")) . S DDMPPATH=" : "_$P($P(^DD(DDMPSFNO,0),U),"SUB-FIELD")_"Subfile"_DDMPPATH . S DDMPSFNO=^DD(DDMPSFNO,0,"UP") Q $G(DDMPFLNM,$P(^DIC(DDMPSFNO,0),U))_DDMPPATH ; UP1 ; ;Called from post-action on Field Selection prompt if null entered. S DDMPFCAP=$P($G(DDMPFCAP)," : ",1,$L($G(DDMPFCAP)," : ")-1) S DDMPCF=$P(DDMPCPTH,U,$L(DDMPCPTH,U)) S DDMPCPTH=$P(DDMPCPTH,":",1,$L(DDMPCPTH,":")-1) S DDMPCPNM=$P(DDMPCPNM,":",1,$L(DDMPCPNM,":")-1) Q ; DELFLD ; ;Called from post-action on change of the "Do you want to delete" prompt I DDMPFDCT=0 Q N DDMPL S DDMPL=$L($G(DDMPFDSL(DDMPFDCT-1)),":") I DDMPL=1 D . S DDMPCF=DDMPF . S DDMPFCAP=DDMPFLNM . S (DDMPCPNM,DDMPCPTH)="" E D . S DDMPCF=$P(DDMPFDSL(DDMPFDCT-1),U,$L(DDMPFDSL(DDMPFDCT-1),U)) . S DDMPFCAP=$$PATHNM(+DDMPCF,DDMPFLNM) . S DDMPCPTH=$P(DDMPFDSL(DDMPFDCT-1),":",1,DDMPL-1) . S DDMPCPNM=$P(DDMPFDSL("CAP",DDMPFDCT-1),":",1,DDMPL-1) K DDMPFDSL(DDMPFDCT),DDMPFDSL("CAP",DDMPFDCT),DDMPFDSL("LN",DDMPFDCT) S DDMPFDCT=DDMPFDCT-1 I DDMPOSET S DDMPOSET=DDMPOSET-1 Q ; ; VAL ; ;Called from form level validation. N DDMPMSG ;1)Validate format of import. I (($G(DDMPSMFF("FIXED"))="YES")&($G(DDMPSMFF("FDELIM"))'=""))!(($G(DDMPSMFF("FIXED"))'="YES")&($G(DDMPSMFF("FDELIM"))="")) D G VALERR . D BLD^DIALOG(1821) . S DDSERROR=2 . S DDSBR="FOR_FMT^1^1" . D MSG^DIALOG("AE",.DDMPMSG) ; ;2) If file specified, move fields selected into DR(). Look for DIERRs created during move. I $G(DDMPF)]"" D . I $$GET^DDSVALF("TMP_NM",1,1)]"" D . . S DDMPFDSL=$$GET^DDSVALF("TMP_NM",1,1,"E") . . D TMPL2SQ^DDMP1(DDMPF,.DDMPFDSL) . I '$D(DDMPFDSL(1)) D Q . . S DDSERROR=$G(DDSERROR)+1 . . S DDMPMSG(DDSERROR)="You must specify some fields into which to import data." . . S DDSBR="FLD_JUMP^1^1" . K DDMPDR . S DDMPFDSL=1 . N DDMPDIER S DDMPDIER=$G(DIERR) . D TODR^DDMP1(DDMPF,.DDMPFDSL,.DDMPDR) . I $G(DIERR)>DDMPDIER D . . S DDSERROR=$G(DDSERROR)+DIERR . . D MSG^DIALOG("AE",.DDMPMSG) . . S DDSBR="2.2^1^2" . . K DDMPDR ; VALERR I $G(DDSERROR) D MSG^DDSUTL(.DDMPMSG) Q Q ; FF ; ;Called from post-action on change of the Foreign Format field. N DDMPI I X'="" D . S DDMPSMFF=DDSEXT . S DDMPSMFF("IEN")=X . S DDMPSMFF("FDELIM")=$$GET1^DIQ(.44,X_",",1) . S DDMPSMFF("FIXED")=$$GET1^DIQ(.44,X_",",5) . S DDMPSMFF("QUOTED")=$$GET1^DIQ(.44,X_",",8) . F DDMPI="FIX","FLD_DLM","QUOTE" D . . D PUT^DDSVALF(DDMPI,1,1,"") . . D UNED^DDSUTL(DDMPI,1,1,1) E D . K DDMPSMFF . F DDMPI="FIX","FLD_DLM","QUOTE" D UNED^DDSUTL(DDMPI,1,1,0) Q DDMPSM1^INT^1^60300,29509^0 DDMPSM1 ;SFISC/DPC-IMPORT SCREENMAN CALLS (CONT) ;9/20/96 11:28 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. HOSTHELP ;Called from HELP on the Host File prompt. N DDMPPATH S DDMPPATH=$$GET^DDSVALF("PTH",1,1) K ^TMP($J,"DDMPHOST") D GETHOSTS(DDMPPATH,$NA(^TMP($J,"DDMPHF"))) S ^TMP($J,"DDMPHOST",1)="Enter the name of the host file that contains the data to be imported." I $D(^TMP($J,"DDMPHF")) D . S ^TMP($J,"DDMPHOST",2)="" . S ^TMP($J,"DDMPHOST",3)="These are the files in the "_DDMPPATH_" directory:" . N DDMPHFNM,I S DDMPHFNM="" . F I=4:1 S DDMPHFNM=$O(^TMP($J,"DDMPHF",DDMPHFNM)) Q:DDMPHFNM="" S ^TMP($J,"DDMPHOST",I)=DDMPHFNM S:I#2 ^(I,"F")="?40" . D EN^DDIOL("","^TMP($J,""DDMPHOST"")") K ^TMP($J,"DDMPHF"),^TMP($J,"DDMPHOST") Q ; GETHOSTS(DDMPPATH,DDMPHFAR) ; ;Obtains list of all host files in a specified directory. ;Input: ;DDMPPATH - Directory name w/ full path. ;DDMPHFAR - Target array for output from $$LIST^%ZISH call. N DDMPHF I DDMPPATH="" Q S DDMPHF("*.*")="" K @DDMPHFAR I $$LIST^%ZISH(DDMPPATH,"DDMPHF",DDMPHFAR) Q PAGE2 ; ;Call from page 2 pre-action. I $D(DDMPFRP4) K DDMPFRP4 Q I $G(DDMPF)="" D Q . S DDSBR="F_SEL^1^1" . D HLP^DDSUTL($C(7)_"You must choose a file before you can go to the Field Selection page.") S DDMPCF=$G(DDMPCF,DDMPF) D UNED^DDSUTL("LEN",1,2,$S($G(DDMPSMFF("FIXED"))="YES":0,1:1)) I $G(DDMPSMFF("FIXED"))="YES",DDMPFDCT,'$D(DDMPFDSL("LN")) D . N DDMPHLP . S DDSBR="FLD_DEL" . S DDMPHLP(1)=$C(7) . S DDMPHLP(2)="You have specified a fixed length format for imported data." . S DDMPHLP(3)="However, you have not entered field lengths for fields you have chosen." . S DDMPHLP(4)="So, you must either delete all the fields entered so far" . S DDMPHLP(5)="or change the format to one that is not fixed length." . D HLP^DDSUTL(.DDMPHLP) Q ; LENCHK ; ;Called from the post action on change field of the Length: prompt pop-up page. I X="L" D . S DDSBR="LEN^1^2" E D . D DELFLD^DDMPSM . S DDSBR="FLD^1^2" . D PUT^DDSVALF("FLD",1,2,"") D PUT^DDSVALF(2,1,4,"") Q DDMPU^INT^1^60300,29509^0 DDMPU ;SFISC/DPC-IMPORT USER INTERFACE, TEMPLATE CREATE ;9/12/96 17:07 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. EN ;Entry point for Import Data option. D CLEAN^DIEFU N DIQUIET,DIFM S (DIQUIET,DIFM)=1 N DA N DDMPHOST,DDMPSELF,DDMPFLAG,DDMPDR,DDSSAVE,DDMPSMFF,DDMPHOST,DDMPIORE,DDMPFDSL,DDMPTMPL D Q:'$G(DDSSAVE) . N DDSPARM,DDSFILE,DR . N DDMPF,DDMPCF,DDMPCPNM,DDMPCPTH,DDMPFCAP,DDMPFDCT,DDMPFDNM,DDMPFLNM,DDMPOSET,DDMPX,DDMPFRP4,DDMPOLDF . S DDSFILE=.46,DR="[DDMP SPECIFY IMPORT]",DDSPARM="S" D ^DDS W @IOF I '$D(DDMPSELF) S DDMPFLAG="F" I $G(DDMPIORE)="E" S DDMPFLAG=$G(DDMPFLAG)_"E" I '($G(DDMPTMPL)]""),$D(DDMPSELF) D . N DIR,DIRUT,Y . S DIR(0)="Y" . S DIR("A")="Do you want to store the selected fields in an Import Template" . D ^DIR . I Y D MKTMPL(DDMPSELF,.DDMPFDSL,.DDMPDR) N DIR,DIRUT,Y S DIR(0)="Y" S DIR("A")="Do you want to proceed with the import" S DIR("?",1)="If you answer 'YES', the import will occur now." S DIR("?")="If you answer 'NO', you will need to respecify the import criteria." W ! D ^DIR I 'Y!$G(DIRUT) W !!,"Okay, you can do the import later." Q D FILE^DDMP($G(DDMPSELF),.DDMPDR,$G(DDMPFLAG),.DDMPHOST,.DDMPSMFF) W !! I $G(DIERR) D . W "Following error messages were generated when import failed." . D MSG^DIALOG("","","",3) E I '$G(ZTSK) W "Done." Q ; MKTMPL(DDMPF,DDMPFLDS,DDMPDR) ; Create Import Template. N DDMPTPNM,DDMPTPNO,DDMPRCNO,DDMPOUT,DDMPSQ,DIR,DIRUT,Y F D Q:$G(DDMPOUT)!($G(DDMPTPNM)]"") . S DIR(0)="FA^3:30^K:(X?1P.E) X" . S DIR("?")="Enter name for your import template. It should be 3-30 characters and it should not start with a punctuation character" . S DIR("A")="Name of Import Template: " . W ! D ^DIR . I Y']""!$G(DIRUT) S DDMPOUT=1 Q . S DDMPTPNM=Y . S DDMPTPNO=$O(^DIST(.46,"F"_DDMPF,DDMPTPNM,"")) . I DDMPTPNO D DUPNAME(DDMPF,.DDMPTPNM,DDMPTPNO) Q:DDMPTPNM="" . S DIR("A")=" Are you adding '"_DDMPTPNM_"' as a new Import Template" . S DIR(0)="Y" . D ^DIR . I 'Y S DDMPTPNM="" Q . K ^TMP($J,"DDMPFDA") . S ^TMP($J,"DDMPFDA",.46,"+1,",.01)=DDMPTPNM . S ^TMP($J,"DDMPFDA",.46,"+1,",4)=DDMPF . S ^TMP($J,"DDMPFDA",.46,"+1,",5)=DUZ . S ^TMP($J,"DDMPFDA",.46,"+1,",2)=DT . S:DUZ(0)'="@" (^TMP($J,"DDMPFDA",.46,"+1,",3),^TMP($J,"DDMPFDA",.46,"+1,",6))=DUZ(0) . F DDMPSQ=1:1 Q:'$D(DDMPFLDS(DDMPSQ)) D . . N DDMPIENS,DDMPLVLS . . S DDMPIENS="+"_(DDMPSQ+1)_",+1," . . S DDMPLVLS=$L(DDMPFLDS(DDMPSQ),":") . . S ^TMP($J,"DDMPFDA",.463,DDMPIENS,.01)=DDMPSQ . . S ^TMP($J,"DDMPFDA",.463,DDMPIENS,1)=$P($P(DDMPFLDS(DDMPSQ),":",DDMPLVLS),U,2) . . S ^TMP($J,"DDMPFDA",.463,DDMPIENS,2)=+$P(DDMPFLDS(DDMPSQ),":",DDMPLVLS) . . S:$D(DDMPFLDS("LN",DDMPSQ)) ^TMP($J,"DDMPFDA",.463,DDMPIENS,3)=DDMPFLDS("LN",DDMPSQ) . . S:DDMPLVLS>1 ^TMP($J,"DDMPFDA",.463,DDMPIENS,10)=$P(DDMPFLDS(DDMPSQ),":",1,DDMPLVLS-1) . . S ^TMP($J,"DDMPFDA",.463,DDMPIENS,20)=DDMPFLDS("CAP",DDMPSQ) . N DDMPERR S DDMPERR=$G(DIERR) . D UPDATE^DIE("","^TMP($J,""DDMPFDA"")","DDMPRCNO") . I DDMPERR'=$G(DIERR) W !,"An error occurred during the filing of the import template." S DDMPOUT=1 Q . D RECALL^DILFD(.46,DDMPRCNO(1)_",",DUZ) . I DUZ(0)="@" S $P(^DIST(.46,DDMPRCNO(1),0),U,3)="@",$P(^(0),U,6)="@" I $G(DDMPOUT) W !,"No import template will be created." Q ; DUPNAME(DDMPF,DDMPTPNM,DDMPTPNO) ;selected template exists. ;If Import template name remains in DDMPTPNM after subroutine, ;user has chosen to delete existing template. W !!,"Import Template "_DDMPTPNM_" already exists." N DDMPDLOK S DDMPDLOK=0 I DUZ(0)="@" D . S DDMPDLOK=$$CKDLT E D . N DDMPWRAC,I . S DDMPWRAC=$$GET1^DIQ(.46,DDMPTPNO_",",6) . F I=1:1:$L(DDMPWRAC) I DUZ(0)[$E(DDMPWRAC,I) S DDMPDLOK=$$CKDLT Q I DDMPDLOK D . N DIK,DA S DIK="^DIST(.46,",DA=DDMPTPNO D ^DIK . W !,"Existing Import Template "_DDMPTPNM_" has been deleted." E S DDMPTPNM="" W !!,"Choose another template name." Q ; CKDLT() ; ;user has write access to the template. Do they want to delete it? N DIR,DIRUT S DIR(0)="Y" S DIR("A")="Do you want to replace the existing template with a new one" S DIR("?",1)="If you answer 'YES', the existing template will be deleted." S DIR("?")="Answer YES or NO." D ^DIR I 'Y!$G(DIRUT) Q 0 Q 1 DDPA1^INT^1^60300,29509^0 DDPA1 ;SFISC/TKW RESET IX NODES ON HAND-EDITED TEMPLATES ;5/12/95 11:23 V ;;22.0T1;VA FileMan;;Dec 02, 1998 ;Per VHA Directive 10-93-142, this routine should not be modified. EN ; N A,B,I,J,X,DIR S DIR("?",1)="This will repair known hand-edited templates in national packages.",DIR("?",2)="If none show on the report, it means that none of the templates on your system" S DIR("?")="needed to be repaired." S DIR(0)="Y",DIR("A")="Repair ""IX"" nodes on hand-edited templates",DIR("B")="Yes" D ^DIR Q:Y'=1 W !!,"Searching Sort Template file...please wait",!!,"Report of templates repaired",!! K ^TMP($J) S U="^" S ^TMP($J,"DG FEMALE INPATIENTS")="^DPT(""CN"",^DPT(^2" S ^TMP($J,"RT WARD LIST")="^DPT(""AA"",^DPT(^2" S J="RT CHARGED BY HOME BY BOR^RT CHARGED BY HOME BY NAME^RT OVER BY HOME BY BOR^RT OVER BY HOME BY NAME^RT OVER BY DIV BY BOR^RT OVER BY DIV BY NAME^RT OVER BY DIV BY TD^RT OVER BY HOME BY TD^RT CHARGED BY HOME BY TD" F I=1:1 S X=$P(J,U,I) Q:X="" S ^TMP($J,X)="^RT(""AC"",^RT(^2" S J="RT HOME LIST BY BOR^RT HOME LIST BY NAME^RT HOME LIST BY TD" F I=1:1 S X=$P(J,U,I) Q:X="" S ^TMP($J,X)="^RT(""AH"",^RT(^2" S ^TMP($J,"RT LOOSE FILING")="^RT(""AL"",^RT(^2" S ^TMP($J,"DGPT WORKFILE")="^DG(45.85,""ACENSUS"",^DG(45.85,^2" S ^TMP($J,"A1B2 OUTPUT1")="^A1B2(11500.2,""AREM"",^A1B2(11500.2,^2" S ^TMP($J,"DG PTF NO ADMISSION")="^DGPM(""ATT3"",^DGPM(^2" S (^TMP($J,"XTLK KEYWORD ALPHA"),^TMP($J,"XTLK KEYWORD CODES"))="^XT(8984.1,""AD"",^XT(8984.1,^2" F I=0:0 S I=$O(^DIBT(I)) Q:'I S X=$P($G(^(I,0)),U) I $D(^TMP($J,X)) D . S B=$G(^DIBT(I,2,1,"IX")),A=^TMP($J,X) Q:A=B . W X,!," Before: ",B,! . S ^DIBT(I,2,1,"IX")=A . W " After: ",^DIBT(I,2,1,"IX"),! . Q K ^TMP($J) W !!!,"DONE!!",! Q DDPA2^INT^1^60300,29509^0 DDPA2 ;SFISC/TKW FIND NON-CANONIC SORT RANGES WITH NO ASK NODE ;8/8/95 10:46 V ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. EN ; This routine will find any sort templates that have a sort field ; with a range that is FROM or TO a non-canonic number, has no ; ASK node, and that has ; had an extra space inserted by FM21 prior to patch DI*21*9. N I,J,X,Y,DIR,DIERR,DTOUT,DIRUT,DIROUT,DUOUT W !!,"This routine will report any sort templates that have been corrupted due to",!,"a bug in FM21 that has been repaired by patch DI*21*9.",!! W "If any templates are reported here, you can repair them by editing the template,",!,"without changing any of the sort fields.",! S DIR("?",1)="This routine will report any sort templates that may have been corrupted.",DIR("?",2)="If none show on the report, it means that none of the templates on your system" S DIR("?")="needed to be edited." S DIR(0)="Y",DIR("A")="Report corrupted sort templates",DIR("B")="Yes" D ^DIR K DIR Q:Y'=1 W !!,"Searching Sort Template file...please wait",!!,"Report of templates that need to be repaired",!! F I=0:0 S I=$O(^DIBT(I)) Q:'I S X=$P($G(^(I,0)),U) D . S DIERR=0 F J=0:0 Q:DIERR=1 S J=$O(^DIBT(I,2,J)) Q:'J I $P($G(^(J,0)),U,10)=4,'$G(^("ASK")),$G(^("SRTTXT"))]"" D .. S Y=$P($G(^DIBT(I,2,J,"F")),U,2) I Y?1." "1.E S DIERR=1 Q .. S Y=$P($G(^DIBT(I,2,J,"T")),U,2) I Y?1." "1.E S DIERR=1 Q .. Q . I DIERR=1 W "No. "_I_" Name: "_X,! . Q Q DDR^INT^1^60300,29509^0 DDR ;ALB/MJK,SF/DCM-FileMan Delphi Components' RPCs ;4/28/98 10:38 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; Q LISTC(DDRDATA,DDR) ; -- broker callback to get list data N DDRFILE,DDRIENS,DDRFLDS,DDRMAX,DDRFROM,DDRPART,DDRXREF,DDRSCRN,DDRID,DDRVAL,DDRERR,DDRRSLT,DDRFLD,DDRFLAGS,DDROPT,DDROUT ; -- parse array to parameters D PARSE(.DDR) S DDRPART=$TR(DDRPART,$C(13)_$C(10),"") ; -- get specific field criteria IF $G(DDR("DDFILE")),$G(DDR("DDFIELD")),$D(^DD(DDR("DDFILE"),DDR("DDFIELD"),12.1)) D . N DIC X ^(12.1) S:$D(DIC("S")) DDRSCRN=DIC("S") I 'XWBAPVER D V0 Q I XWBAPVER>0 D V1 Q Q ; DIC D LIST^DIC(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRMAX,.DDRFROM,DDRPART,DDRXREF,DDRSCRN,DDRID,DDROUT,"DDRERR") Q ; V0 S DDROUT="DDRRSLT",DDRFLAGS=$G(DDRFLAGS)_"P",DDRFLDS=$G(DDRFLDS)_";@" D DIC N Y,I,N S N=0 I $G(DDRFROM)]"" D SET("[Misc]"),SET("MORE"_U_DDRFROM_U_DDRFROM("IEN")) I $D(DDRRSLT("DILIST")) D . D SET("[Data]") . S I=0 F S I=$O(DDRRSLT("DILIST",I)) Q:'I D SET(DDRRSLT("DILIST",I,0)) IF $D(DDRERR) D SET("[Errors]") S X=$$STYPE^XWBTCPC("ARRAY") Q ; V1 S DDROUT="" I XWBAPVER=1,DDRFLAGS["P" S DDRFLAGS=DDRFLAGS_"S" ;only P flag is sent from client for V1 of FMCD D DIC I $G(DDRFLAGS)["P" D Q . I $D(^TMP("DILIST",$J)) D . . N END S END=+^TMP("DILIST",$J,0) . . I XWBAPVER>1 S ^(.3)="[MAP]",^TMP("DILIST",$J,.4)=^TMP("DILIST",$J,0,"MAP") . . K ^TMP("DILIST",$J,0) S ^(.5)="[BEGIN_diDATA]",^(END+1)="[END_diDATA]" . D 11,31 . S DDRDATA=$NA(^TMP("DILIST",$J)) . Q I $G(DDRFLAGS)'["P" D 11,UNPACKED,31 S DDRDATA=$NA(^TMP("DILIST",$J)) Q Q 11 I $G(DDRFROM)]"" S ^TMP("DILIST",$J,.1)="[Misc]",^(.2)="MORE"_U_DDRFROM_U_DDRFROM("IEN")_$S(XWBAPVER>1:U_$P($G(^TMP("DILIST",$J,0)),U,4),1:"") Q 31 I $D(DIERR) D ERROR Q SET(X) ; S N=N+1 S DDRDATA(N)=X Q PARSE(DDR) ; -- array parsing S DDRFILE=$G(DDR("FILE")) S DDRIENS=$G(DDR("IENS")) S DDRFLDS=$G(DDR("FIELDS")) S DDRFLAGS=$G(DDR("FLAGS")) S DDRMAX=$G(DDR("MAX"),"*") M DDRFROM=DDR("FROM") S DDRPART=$G(DDR("PART")) S DDRXREF=$G(DDR("XREF")) S DDRSCRN=$G(DDR("SCREEN")) S DDRID=$G(DDR("ID")) S DDROPT=$G(DDR("OPTIONS")) Q ERROR ; N I S I=1 D Z("[BEGIN_diERRORS]") N A S A=0 F S A=$O(DDRERR("DIERR",A)) Q:'A D . N HD,PARAM,B,C,TEXT,TXTCNT,D,FILE,FIELD,IENS . S HD=DDRERR("DIERR",A) . I $D(DDRERR("DIERR",A,"PARAM",0)) D . . S (B,D)=0 F C=1:1 S B=$O(DDRERR("DIERR",A,"PARAM",B)) Q:B="" D . . . I B="FILE" S FILE=DDRERR("DIERR",A,"PARAM","FILE") . . . I B="FIELD" S FIELD=DDRERR("DIERR",A,"PARAM","FIELD") . . . I B="IENS" S IENS=DDRERR("DIERR",A,"PARAM","IENS") . . . S D=D+1,PARAM(D)=B_U_DDRERR("DIERR",A,"PARAM",B) . S C=0 F S C=$O(DDRERR("DIERR",A,"TEXT",C)) Q:'C S TEXT(C)=DDRERR("DIERR",A,"TEXT",C),TXTCNT=C . S HD=HD_U_TXTCNT_U_$G(FILE)_U_$G(IENS)_U_$G(FIELD)_U_$G(D) D Z(HD) . S B=0 F S B=$O(PARAM(B)) Q:'B S %=PARAM(B) D Z(%) . S B=0 F S B=$O(TEXT(B)) Q:'B S %=TEXT(B) D Z(%) . Q D Z("[END_diERRORS]") Q Z(%) ; S ^TMP("DILIST",$J,"ZERR",I)=%,I=I+1 Q ; UNPACKED ; Q:'$D(^TMP("DILIST",$J)) N COUNT,IXCNT S COUNT=+^TMP("DILIST",$J,0) Q:'COUNT I XWBAPVER>1 S ^TMP("DILIST",$J,.3)="[MAP]",^TMP("DILIST",$J,.4)=^TMP("DILIST",$J,0,"MAP") K ^TMP("DILIST",$J,0) S ^TMP("DILIST",$J,.5)="[BEGIN_diDATA]" I XWBAPVER=1 D IX1 D IENS,FLDS,WID,END Q IX1 I DDROPT["IX",$D(^TMP("DILIST",$J,1)) D . S ^TMP("DILIST",$J,1,COUNT+1)="END_IXVALUES" D S ^(.1)="BEGIN_IXVALUES",^(.2)=IXCNT . . N Z S Z=0,IXCNT=0 I $G(^TMP("DILIST",$J,1,1))]"" S IXCNT=1 Q . . F S Z=$O(^TMP("DILIST",$J,1,1,Z)) Q:'Z S IXCNT=IXCNT+1 I DDROPT'["IX" K ^TMP("DILIST",$J,1) Q IENS I $D(^TMP("DILIST",$J,2)) D . S ^TMP("DILIST",$J,2,.1)="BEGIN_IENs",^(COUNT+1)="END_IENs" Q FLDS I DDRFLDS]"",$D(^TMP("DILIST",$J,"ID")) D . N Z,FLD,FLDCNT S FLD="",(Z,FLDCNT,I)=0 . ;I XWBAPVER>1,DDRFLDS["IX" D . ;. F S I=$O(^TMP("DILIST",$J,"ID",1,0,I)) Q:'I S IXCNT=IXCNT+1 . ;. S ^TMP("DILIST",$J,"ID",0,0)="IXCNT="_IXCNT Q . F S Z=$O(^TMP("DILIST",$J,"ID",1,Z)) Q:'Z S FLD=FLD_Z_";",FLDCNT=FLDCNT+1 . Q:'FLDCNT . S ^TMP("DILIST",$J,"ID",0)="BEGIN_IDVALUES" . I XWBAPVER=1 S ^TMP("DILIST",$J,"ID",.1)=FLD_U_FLDCNT . S ^TMP("DILIST",$J,"ID",COUNT+1)="END_IDVALUES" E D . N Z S Z=0 F S Z=$O(^TMP("DILIST",$J,"ID",Z)) Q:'Z K ^TMP("DILIST",$J,"ID",Z) Q WID I (DDROPT["WID")!(DDRFLDS["WID"),$D(^TMP("DILIST",$J,"ID","WRITE")) D . N Z,N,I,IEN,WIDCNT S (N,I)=0 . M Z=^TMP("DILIST",$J,"ID","WRITE") K ^TMP("DILIST",$J,"ID","WRITE") . S ^TMP("DILIST",$J,"ID","WID",0)="BEGIN_WIDVALUES",N=N+1 . F S I=$O(Z(I)) Q:'I S IEN=$G(^TMP("DILIST",$J,2,I)) D . . N J S (J,WIDCNT)=0 F S J=$O(Z(I,J)) Q:'J S WIDCNT=WIDCNT+1 . . S ^TMP("DILIST",$J,"ID","WID",N)="WID"_U_IEN_U_WIDCNT,N=N+1 . . N J S J=0 F J=1:1:WIDCNT S ^TMP("DILIST",$J,"ID","WID",N)=Z(I,J),N=N+1 . S ^TMP("DILIST",$J,"ID","WID",N)="END_WIDVALUES" I (DDROPT'["WID")&(DDRFLDS'["WID") K ^TMP("DILIST",$J,"ID","WRITE") Q END S ^TMP("DILIST",$J,"IDZ")="[END_diDATA]" Q DDR0^INT^1^60300,29509^0 DDR0 ;SF/DCM-FileMan Delphi Components' RPCs ;4/28/98 10:52 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; Q FINDC(DDRDATA,DDR) ; -- broker callback to get list data N DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRVAL,DDRMAX,DDRXREF,DDRSCRN,DDRID,DDRROOT,DDRERR,DDRRSLT,DDROPT,DDROUT ; -- parse array to parameters D PARSE(.DDR) S DDROUT="" D FIND^DIC(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRVAL,DDRMAX,DDRXREF,DDRSCRN,DDRID,DDROUT,"DDRERR") I $G(DDRFLAGS)["P" D . Q:'$D(^TMP("DILIST",$J)) . N COUNT S COUNT=^TMP("DILIST",$J,0) Q:'COUNT D 1 . I XWBAPVER>1 S ^(.3)="[MAP]",^TMP("DILIST",$J,.4)=^TMP("DILIST",$J,0,"MAP") . K ^TMP("DILIST",$J,0) S ^(.5)="[BEGIN_diDATA]",^(COUNT+1)="[END_diDATA]" . Q I $G(DDRFLAGS)'["P" D . Q:'$D(^TMP("DILIST",$J)) . N COUNT S COUNT=^TMP("DILIST",$J,0) Q:'COUNT . D 1,UNPACKED . Q D 3,4 Q 1 Q:'$P(COUNT,U,3) S ^TMP("DILIST",$J,.1)="[Misc]",^(.2)="MORE" Q 3 I $D(DIERR) D ERROR Q 4 S DDRDATA=$NA(^TMP("DILIST",$J)) Q PARSE(DDR) ; -- array parsing S DDRFILE=$G(DDR("FILE")) S DDRIENS=$G(DDR("IENS")) S DDRFLDS=$G(DDR("FIELDS")) S DDRFLAGS=$G(DDR("FLAGS")) S DDRMAX=$G(DDR("MAX"),"*") S DDRVAL=$G(DDR("VALUE")) S DDRXREF=$G(DDR("XREF")) S DDRSCRN=$G(DDR("SCREEN")) S DDRID=$G(DDR("ID")) S DDRROOT=$G(DDR("ROOT")) S DDROPT=$G(DDR("OPTIONS")) Q ERROR ; N I S I=1 D Z("[BEGIN_diERRORS]") N A S A=0 F S A=$O(DDRERR("DIERR",A)) Q:'A D . N HD,PARAM,B,C,TEXT,TXTCNT,D,FILE,FIELD,IENS . S HD=DDRERR("DIERR",A) . I $D(DDRERR("DIERR",A,"PARAM",0)) D . . S (B,D)=0 F C=1:1 S B=$O(DDRERR("DIERR",A,"PARAM",B)) Q:B="" D . . . I B="FILE" S FILE=DDRERR("DIERR",A,"PARAM","FILE") . . . I B="FIELD" S FIELD=DDRERR("DIERR",A,"PARAM","FIELD") . . . I B="IENS" S IENS=DDRERR("DIERR",A,"PARAM","IENS") . . . S D=D+1,PARAM(D)=B_U_DDRERR("DIERR",A,"PARAM",B) . S C=0 F S C=$O(DDRERR("DIERR",A,"TEXT",C)) Q:'C S TEXT(C)=DDRERR("DIERR",A,"TEXT",C),TXTCNT=C . S HD=HD_U_TXTCNT_U_$G(FILE)_U_$G(IENS)_U_$G(FIELD)_U_$G(D) D Z(HD) . S B=0 F S B=$O(PARAM(B)) Q:'B S %=PARAM(B) D Z(%) . S B=0 F S B=$O(TEXT(B)) Q:'B S %=TEXT(B) D Z(%) . Q D Z("[END_diERRORS]") Q Z(%) ; S ^TMP("DILIST",$J,"ZERR",I)=%,I=I+1 Q UNPACKED ; K ^TMP("DILIST",$J,0) S ^TMP("DILIST",$J,.5)="[BEGIN_diDATA]" K ^TMP("DILIST",$J,1) S ^TMP("DILIST",$J,2,.1)="BEGIN_IENs",^(COUNT+1)="END_IENs" I DDRFLDS]"",$D(^TMP("DILIST",$J,"ID")) D . N Z,FLD,FLDCNT S Z=0,FLD="",FLDCNT=0 . F S Z=$O(^TMP("DILIST",$J,"ID",1,Z)) Q:'Z S FLD=FLD_Z_";",FLDCNT=FLDCNT+1 . Q:'FLDCNT . S ^TMP("DILIST",$J,"ID",0)="BEGIN_IDVALUES",^(.1)=FLD_U_FLDCNT,^(COUNT+1)="END_IDVALUES" E D . N Z S Z=0 F S Z=$O(^TMP("DILIST",$J,"ID",Z)) Q:'Z K ^TMP("DILIST",$J,"ID",Z) I $G(DDROPT)["WID",$D(^TMP("DILIST",$J,"ID","WRITE")) D . N Z,N,I,IEN,WIDCNT S (N,I)=0 . M Z=^TMP("DILIST",$J,"ID","WRITE") K ^TMP("DILIST",$J,"ID","WRITE") . S ^TMP("DILIST",$J,"ID","WID",0)="BEGIN_WIDVALUES",N=N+1 . F S I=$O(Z(I)) Q:'I S IEN=$G(^TMP("DILIST",$J,2,I)) D . . N J S (J,WIDCNT)=0 F S J=$O(Z(I,J)) Q:'J S WIDCNT=WIDCNT+1 . . S ^TMP("DILIST",$J,"ID","WID",N)="WID"_U_IEN_U_WIDCNT,N=N+1 . . N J S J=0 F J=1:1:WIDCNT S ^TMP("DILIST",$J,"ID","WID",N)=Z(I,J),N=N+1 . S ^TMP("DILIST",$J,"ID","WID",N)="END_WIDVALUES" I $G(DDROPT)'["WID" K ^TMP("DILIST",$J,"ID","WRITE") S ^TMP("DILIST",$J,"IDZ")="[END_diDATA]" Q DDR1^INT^1^60300,29509^0 DDR1 ;ALB/MJK-FileMan Delphi Components' RPCs ;4/18/97 16:15 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; Q ; DIKC(DDROK,DDR) ; -- broker callback to kill a file entry via ^DIK N DIK,DA,FILE,IENS,FDA S FILE=$G(DDR("FILE")) S IENS=$G(DDR("IENS")) I $$FNO^DILIBF(FILE)=FILE,$L(IENS,",")=2 D Q . S DIK=$G(^DIC(FILE,0,"GL")),DA=+IENS D ^DIK S DDROK=1 S FDA(FILE,IENS,.01)="@" D FILE^DIE("","FDA") S DDROK='$G(DIERR) Q ; LOCKC(DDROK,DDR) ; -- broker callback to lock/unlock a node N DDRNODE S DDRNODE=$G(DDR("NODE")) IF DDRNODE]"" D . IF $G(DDR("LOCKMODE")) D . . L @("+"_DDRNODE_":"_$G(DDR("TIMEOUT"),5)) . . S DDROK=$T . ELSE D . . L @("-"_DDRNODE) . . S DDROK=1 ELSE D . S DDROK=0 Q ; FILENOC(DDRFLNO,DDRNAME) ; -- broker callback to get File # ; S DDRFLNO=+$O(^DIC("B",DDRNAME,"")) Q ; NODEC(DDRNODE,DDRROOT) ; -- broker callback to get global node value ; ;S DDRNODE=$G(@DDRROOT) IF $D(@DDRROOT)=0!($D(@DDRROOT)=10) D . S DDRNODE="{{"_$D(@DDRROOT)_"}}" IF $D(@DDRROOT)=1!($D(@DDRROOT)=11) D . S DDRNODE=$G(@DDRROOT) Q ; GLCNT(DDROK,DDR) ; -- extrinsic call to invoke broker to return number of ; global nodes found at cross reference N DDRNODE,DDRTEAM,DDRXREF ; S DDRNODE=$G(DDR("ROOT")) S DDRXREF=$G(DDR("XREF")) S DDRVAL=$G(DDR("VALUE")) ; S:DDRXREF="" DDRXREF="B" S I="",X=0 F S I=$O(@DDRNODE@(DDRXREF,DDRVAL,I)) Q:I="" D . S X=X+1 S DDROK=$G(X) Q ; IFNODE(DDRNODE,DDRROOT) ; -- extrinsic call to check if node exists. ; passes in full node reference N X ; IF $D(@DDRROOT)=0!($D(@DDRROOT)=10) D . S DDRNODE="{{"_$D(@DDRROOT)_"}}" IF $D(@DDRROOT)=1!($D(@DDRROOT)=11) D . S DDRNODE=$G(@DDRROOT) Q DDR2^INT^1^60300,29509^0 DDR2 ;ALB/MJK-FileMan Delphi Components' RPCs ;4/20/98 11:38 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; Q ; FIND1C(DDRDATA,DDR) ; DDR FIND1 rpc callback N DDRFILE,DDRIENS,DDRFLAGS,DDRVAL,DDRXREF,DDRSCRN,DDRERR,A,IEN,N D PARSE(.DDR) S DDRVAL=$G(DDR("VALUE")) S A=$$FIND1^DIC(DDRFILE,DDRIENS,DDRFLAGS,DDRVAL,DDRXREF,DDRSCRN,"DDRERR") S A=$S($G(DIERR):"",1:A) S N=0 D SET(A) I $G(DIERR) D ERROR Q I $G(DDROPT)["R" S IEN=$S($G(DDRIENS)]"":A_DDRIENS,1:A_",") D RECALL^DILFD(DDRFILE,IEN,DUZ) Q ; GETSC(DDRDATA,DDR) ; DDR GETS ENTRY DATA rpc callback N DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDROPT,DDRRSLT,DDRERR N DDRXREF,DDRSCRN,N D PARSE(.DDR) D GETS^DIQ(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,"DDRRSLT","DDRERR") S N=0 I '$D(DDROPT) D 1,2 Q I $G(DDROPT)["U" D 11,21 I $G(DDROPT)["?" D HLP Q 1 I $D(DDRRSLT) D . N DDRFIELD,X,J . D SET("[Data]") . S DDRFIELD=0 F S DDRFIELD=$O(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD)) Q:'DDRFIELD D . . ;Do not remove stripping of ',' from IENS in line below if this code should work with T11 (21.1T1) of FM components. . . S X=DDRFILE_"^"_$E(DDRIENS,1,$L(DDRIENS)-1)_"^"_DDRFIELD_"^" . . ; -- below call to $$GET1 is too slow...working w/FM team for speed . . ;IF $$GET1^DID(DDRFILE,DDRFIELD,"","TYPE")="WORD-PROCESSING" D . . ;IF $P($G(^DD(DDRFILE,DDRFIELD,0)),U,4)[";0" D <0 HLP^DDSMSG() G END^DDS0 ; PROC ;Main loop F D PG Q:DDACT="Q" Q ; PG ;Load page N DDSMX,DDSMY,DDSMOUSE,FND S DDACT="N" D ^DDS1(DDSPG) I $G(DIERR) D Q . N P S P(1)=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U),P(2)=$P($G(^(1)),U) . S:P(2)="" P(2)="unnamed" . D BLD^DIALOG(3041,.P),ERR^DDSMSG H 2 . S DDACT="Q" ; ;Pre-action, save old and get next page S DDSOPB=DDSPG I $G(^DIST(.403,+DDS,40,DDSPG,11))'?."^" D PA(^(11)) Q:DDACT="NP" S DDSNP=$$NP^DDS5(.Y) S:'Y DDSNP="" ; ;Get DDO and DDSBK I $S($D(DDSBR)[0:1,1:$D(@DDSREFS@(DDSPG,$S(DDO:+DDSBK,1:0),DDO,"N"))[0) D . S DDO=+$G(@DDSREFS@(DDSPG,"FIRST")),DDSBK=$P($G(^("FIRST")),",",2) I 'DDSBK D Q . D BLD^DIALOG(3055,"number "_$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U)_$S($G(^(1))]"":" ("_$P($G(^(1)),U)_")",1:"")) . D ERR^DDSMSG H 2 . S DDACT="Q" ; ;Get DDSPOP and update DDSSC array ;If we're going to another page I '$D(DDSPGUP) D . S DDSLN=^DIST(.403,+DDS,40,DDSPG,0),DDSPOP=$P(DDSLN,U,6) . K:'DDSPOP DDSSC SEL . I $D(DDSSEL),+$G(^DIST(.403,+DDS,21))=DDSPG D ;IF IT'S (REALLY) A RECORD SELECTION PAGE FORGET DA .. S DDSDASV=DDSDA,DDSDLSV=DDSDL .. M DDSORGSV=DDSDAORG .. K DA,@$$D0(DDSDL),DDSDAORG .. S (DA,D0,DDSDAORG)="",DDSDA="0,",DDSDL=0 . I '$D(DDSSC("B",DDSPG)) D .. S DDSSC=$G(DDSSC)+1,DDSSC(DDSSC)=DDSPG,DDSSC("B",DDSPG,DDSSC)="" .. S:DDSPOP $P(DDSSC(DDSSC),U,2,3)=$P(DDSLN,U,3)_U_$P(DDSLN,U,7) .. I $G(DDSSTK) S $P(DDSSC(DDSSC),U,4)=1 K DDSSTK .. K DDSPOP . E D .. Q:$P($G(DDSSC(+$G(DDSSC))),U)=DDSPG .. N I,J,S .. S I=$O(DDSSC("B",DDSPG,"")),S=DDSSC(I) K DDSSC("B",DDSPG,I) .. F J=I:1:DDSSC-1 D ... K DDSSC("B",$P(DDSSC(J+1),U),J) ... S DDSSC(J)=DDSSC(J+1),DDSSC("B",$P(DDSSC(J),U),J)="" .. S DDSSC(DDSSC)=S,DDSSC("B",DDSPG,DDSSC)="" ; ;If we've moving up from a pop-up page E K DDSPGUP ; ;Paint the page D RP^DDSR(DDSSC(DDSSC),DDSSC=1) ; P1 F D BLK Q:"^Q^NP^"[(U_DDACT_U) ; ;PAGE Post action, print any help D:$G(^DIST(.403,+DDS,40,+DDSOPB,12))'?."^" PA(^(12)) D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG() G:"^NB^N^"[(U_DDACT_U) P1 ; I DDACT="Q" D . I '$P(DDSSC(DDSSC),U,4) D .. I $G(DDSSEL) D GDA^DDSRSEL Q:'DA ;Do the RECORD SELECTION Page, if there is one .. D:$G(DDSSC)>1 CLEAR^DDSBOX($P(DDSSC(DDSSC),U,2),$P(DDSSC(DDSSC),U,3)) .. S:DDSSC>1 DDSPG=$P(DDSSC(DDSSC-1),U),DDACT="N",DDSPGUP=1 . K DDSSC("B",$P(DDSSC(DDSSC),U),DDSSC),DDSSC(DDSSC) S DDSSC=DDSSC-1 Q ; BLK S DDACT="N",DDSOSV=0 ; I $D(@DDSREFS@(DDSPG,DDSBK))[0 S DDACT="Q" Q S DDSLN=@DDSREFS@(DDSPG,DDSBK) ; S DDSDN=$P(DDSLN,U,4),DDSTP=$P(DDSLN,U,5) S DDSREP=$P(DDSLN,U,7),DDSPTB=$P(DDSLN,U,8) K:'DDSDN DDSDN K:DDSTP="e" DDSTP K:'DDSPTB DDSPTB K:DDSREP'>1 DDSREP ; I $D(DDSPTB)!$D(DDSREP) N DDP,DDSDA,DIE D ;NEW WHEN WE GO INTO MULTIPLE!! . S DDP=$P(DDSLN,U,3) DIE . S DDSDA=$P(@DDSREFT@(DDSPG,DDSBK),U) I DDSDA'>0,$G(^(DDSBK,"COMP MUL"))="" S DIE=$G(DIE) Q ;Get Entry Number . S DIE=@DDSREFT@(DDSPG,DDSBK,DDSDA,"GL") ; I $D(DDSPTB) N DA,@$$D0(DDSDL),DDSDL D . S DDSPTB=@DDSREFS@(DDSPG,DDSBK,"PTB") . S DDSDL=$L(DDSDA,",")-2 . S (D0,DA)=+DDSDA ; I $D(DDSREP) N DDSDL,DA D . S DDSREP=$P(@DDSREFT@(DDSPG,DDSBK,DDSDA),U,2,999) . S DDSDA=$G(@DDSREFT@(DDSPG,DDSBK,$P(DDSREP,U),$P(DDSREP,U,4)),"0,"_DDSDA) ;2-arg $G -- go to empty line if none other specified . S:'$P(DDSREP,U,7) DDSDA=$P(DDSDA,",")_"," . S DDSDL=$L(DDSDA,",")-2 I N @$$D0(DDSDL) D . D BLDDA(DDSDA) . S:'DA DDO=+$P(DDSREP,U,8) ;If this is a new subEntry, start at 1st editable field ; PTB I $D(DDSPTB),'$D(DDSREP),'DDSDA,DDSDAORG D Q . N DDSBK0 . S DDSBK0=DDSBK . F S DDSBK=$$NB^DDS5(.Y) Q:DDSBK=DDSBK0!'Y!$G(@DDSREFT@(DDSPG,DDSBK)) . Q:Y . I DDSNP]"" S DDSPG=DDSNP,DDACT="NP" Q . S DDSPG=$$PP^DDS5(.Y) I Y S DDACT="NP" Q . S DDACT="Q" ; S $P(DDSOPB,U,2)=DDSBK I $G(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,11))'?."^" D PA(^(11)) Q:DDACT="NP" I $G(^DIST(.404,DDSBK,11))'?."^" D PA(^(11)) Q:DDACT="NP" 1 I $S($D(DDSBR)[0:1,1:$D(@DDSREFS@(DDSPG,$S(DDO:+DDSBK,1:0),DDO,"N"))[0) D . S DDO=$P(@DDSREFS@(DDSPG,DDSBK),U,9) ;First field K DDSLN ; B1 D ^DDS01 ; I $G(^DIST(.403,+DDS,40,DDSPG,40,$P(DDSOPB,U,2),12))'?."^" D PA(^(12)) G:DDACT="N" B1 I $G(^DIST(.404,$P(DDSOPB,U,2),12))'?."^" D PA(^(12)) G:DDACT="N" B1 Q ; BLDDA(DDSDA) ; N I S (DA,@("D"_DDSDL))=$P(DDSDA,",") F I=1:1:DDSDL S (DA(I),@("D"_(DDSDL-I)))=$P(DDSDA,",",I+1) Q ; D0(DL) ;Given DL, return string D0,D1,...,Dn N I,S S S="" F I=0:1:DL S S=S_"D"_I_"," S:S?.E1"," S=$E(S,1,$L(S)-1) Q S ; CLRMSG ; I $G(DDSKM) H 2 K DDSKM ;GFT ** IF WE WERE KEEPING SOMETHING IN HELP AREA, HOLD UP 2 SECONDS ISB-0603-31054 K DDQ S DDSH=1,(DDM,DX)=0,DY=DDSHBX+1 X DDXY W $P(DDGLCLR,DDGLDEL,3) ;CLEAR WHOLE COMMAND AREA F S DDQ=$O(DDSMOUSE(DDSHBX)) Q:DDQ+1=IOSL!'DDQ K DDSMOUSE(DDQ) Q ; PA(DDSPA) ; N DDSBRORG S:$D(DDSBR)#2 DDSBRORG=DDSBR K DDSBR X DDSPA ;PRE-ACTION I $D(DDSBR)[0 S:$D(DDSBRORG)#2 DDSBR=DDSBRORG Q D BR^DDS2 Q ; ; ; ; ; ; RESET ;Programmer entry point to reset terminal and cleanup D INIT^DDGLIB0() D:$G(DIERR) MSG^DIALOG("BW") W $P($G(DDGLVID),DDGLDEL,10) K DDSPARM S DDSREFT="^TMP(""DDS"",$J)" D END^DDS0 G RESET^DDGF ; RUN ;Run a form G ^DDSRUN CLONE ;Clone a form G ^DDSCLONE PRINT ;Print a form G ^DDSPRNT DFRM ;Delete a form G ^DDSDFRM DBLK ;Delete unused blocks G ^DDSDBLK DDS0^INT^1^60300,29509^0 DDS0 ;SFISC/MLH-SETUP, CLEANUP ;24FEB2004 ;;22.0;VA FileMan;**999,1003,1012**;Mar 30, 1999 ; EN(DDSFILE,DR,DA) ;Initial setup S U="^" D INIT^DDGLIB0() Q:$G(DIERR) D FORM(.DDSFILE,DR) Q:$G(DIERR) ; ;Compile the form if not already compiled S DDSREFS=$$REF(DDS) I '$$COMPILED(DDS) D EN^DDSZ(DDS) Q:$G(DIERR) N:$P(^DIST(.403,+DDS,0),U,10) DA ; D FRSTPG(DDS,.DA,$G(DDSPAGE)) Q:$G(DIERR) D REC(DDP,.DA) Q:$G(DIERR) D INIT Q ; FORM(DDSFILE,DR) ;Form lookup ;Output: ; DDS = Form number^Form name ; DDP = File number (or 0) ; DDSPG = First page to go to on form ; DIERR ; I $D(DDSFILE)[0 D BLD^DIALOG(201,"DDSFILE") Q ; N DIC,X,Y ; S DDP=$S(DDSFILE=+DDSFILE:DDSFILE,1:+$P($G(@(DDSFILE_"0)")),U,2)) S X=$S(DR:DR,1:$P($P(DR,"[",2),"]")) S DIC="^DIST(.403,",DIC(0)="FNX",D="F"_DDP D IX^DIC K DIC ; I Y<0 D BLD^DIALOG(3021,X) Q I '$O(^DIST(.403,+Y,40,"B","")) D BLD^DIALOG(3022,X) Q S DDS=Y ; I $D(DDSFILE(1))#2 S DDP=$S(DDSFILE(1)=+DDSFILE(1):DDSFILE(1),1:+$P($G(@(DDSFILE(1)_"0)")),U,2)) Q ; FRSTPG(DDS,DA,DDSPAGE) ;Get first page of form ;Output: ; DDSPG ; DDSSEL = 1, if DA is null and there is a record selection page ; DIERR ; N P I $G(DA)!$P(^DIST(.403,+DDS,0),U,10) D . S P=$S($G(DDSPAGE):DDSPAGE,1:1) . S DDSPG=$O(^DIST(.403,+DDS,40,"B",P,"")) . I $D(^DIST(.403,+DDS,40,+DDSPG,0))[0 D BLD^DIALOG(3023,"number "_P) E D PG^DDSRSEL D:'$G(DDSSEL) BLD^DIALOG(202,"record") Q ; REC(DDP,DA) ;Check record and lock ;Output: ; DIE = Global root ; DDSDA = DA,DA(1),..., ; DDSDAORG = Original DA array ; DDSDL = Level number (top=0) ; DDSDLORG = Original level number ; DDSFLORG = Orig DDP^Orig DIE ; D0,D1,etc. ; DIERR ; I '$G(DA) D Q . S DIE="",(DDSDL,DDSDLORG)=0,DDSDA="0," . S DA="",DDSDAORG=DA ; D GL^DDS10(DDP,.DA,.DIE,.DDSDL,.DDSDA,'$P(^DIST(.403,+DDS,0),U,9)) Q:$G(DIERR) ;Don't LOCK record if screen is DISPLAY-ONLY ; I $D(DIOVRD)[0 D Q:$G(DIERR) . N DDSTOP S DDSTOP=$$FNO^DILIBF(DDP) . Q:$P($G(^DD(DDSTOP,0,"DI")),U,2)'["Y" EGP . N P S P("FILE")=$$FILENAME^DIALOGZ(DDSTOP) ;**CCO/NI RESTRICTED FILE NAME . D BLD^DIALOG(405,DDSTOP,.P) ; S DDSDLORG=DDSDL K DDSDAORG S (DDSDAORG,@("D"_DDSDL))=DA F DDSI=1:1:DDSDL S (DDSDAORG(DDSI),@("D"_(DDSDL-DDSI)))=DA(DDSI) S DDSFLORG=$G(DDP)_$G(DIE) K DDSI Q ; INIT ;Initialize some variables ; DDSHBX = $Y of first line of help area ; DDSREFT = Global reference of temporary global location ; DDSFDO = 1 if entire form is display-only ; DDSCHG = Change flag ; DDSKM = Flag to keep whatever's in help area ; DDSH = Flag to indicate help area is empty ; DDSSC = Array to indicate what pages are on the screen ; DDSHBX S DDSHBX=17 I $G(DDS),$G(DDSPG),$D(DDSREFS) D .N % S %=$O(@DDSREFS@("X",DDSPG,""),-1)+1 I %>DDSHBX S DDSHBX=% ;LAST FIELD CAPTION .F DDH=0:0 S DDH=$O(@DDSREFS@(DDSPG,DDH)) Q:'DDH I $G(^(DDH)) S %=$P(^(DDH),U,7)+^(DDH) I %>DDSHBX S DDSHBX=% S DDXY=IOXY_" S $X=DX,$Y=DY" ; K DDH,DDSSC,DDSCHANG,DDSSAVE S DDSH=1,(DDH,DDM,DDSCHG,DDSSC)=0,DDACT="N" DDSREFT S DDSREFT=$NA(^TMP("DDS",$J,+DDS)) ;GFT K @DDSREFT MOUSEON I $G(DDS)>0 W *27,"[?1000h" N %,%H,%I,X D NOW^%DTC S $P(^DIST(.403,+DDS,0),U,6)=$E(%,1,12) Q ; END I $D(DDSHBX) S DX=0,DY=IOSL-1 X IOXY D KILL^DDGLIB0($G(DDSPARM)) ; D:$D(^TMP("DDS",$J,"LOCK")) UNLOCK ; K:'$G(DA) DA I $D(DA),$D(DDSDAORG)#2,$D(DDSDLORG)#2 D . K DA,D0 . S DA=DDSDAORG . F DDSI=1:1:DDSDLORG S DA(DDSI)=DDSDAORG(DDSI) K @("D"_DDSI) MOUSEOFF W *27,"[?1000l" K:$G(DDSPARM)'["E" DIERR,^TMP("DIERR",$J) K:$D(DDSREFT)#2 @DDSREFT,DDSREFT K ^TMP("DDSH",$J),^TMP("DDSWP",$J) K DDACT,DDH,DDM,DDO,DDP,DDQ,DDS,DDSDDP K DDSBK,DDSBR,DDSCHG,DDSDA,DDSDAORG,DDSDL K DDSDLORG,DDSDN,DDSEXT,DDSFDO,DDSFLD,DDSFLORG,DDSGL,DDSH,DDSI K DDSKM,DDSLN,DDSNP,DDSO,DDSOLD,DDSORD,DDSOPB,DDSOSV,DDSPTB,DDSPG K DDSPX,DDSPY,DDSQ,DDSREP,DDSSC,DDSSP,DDSSTACK,DDSTP,DDSU,DDSX K DDSHBX,DDSREFS,DDXY K DIC,DIR,DIR0N,DIROUT,DIRUT,DUOUT,DY,DX K A1,D,DDC,DDD,DI,DIEQ,DIK,DIW,DIY,DIZ,DS Q ; UNLOCK ;Unlock any lock records N I S I="" F S I=$O(^TMP("DDS",$J,"LOCK",I)) Q:I="" L -@I K ^TMP("DDS",$J,"LOCK") Q ; COMPILED(DDS) ;Return 1 if form is compiled Q $D(@$$REF(DDS))>0 ; REF(DDS) ;Return global reference for compiled global Q $NA(^DIST(.403,+DDS,"AY")) ; OLDREF(DDS) ;Return global reference for compiled global used prior ;to version 22.0 Q $NA(^DIST(.403,+DDS,"AZ")) ; IXF ; N D0,DA,DIC,DP,Y S DIC="^DD("_DDGFDD_",",DIC(0)="EN" D ^DIC I Y'>0 K X E S X=+$P(Y,"E") Q DDS01^INT^1^61069,61055^0 DDS01 ;SFISC/MLH,MKO-PROCESS BLOCK ;3SEP2007 ;;22.0;VA FileMan;**8,39,1003,1004,1023,1029**;Mar 30, 1999 ; ;***BE CAREFUL PUTTING TAGS INTO THIS IMPORTANT ROUTINE! $T LOOKS FOR A NON-EXISTENCE OF A TAG!**** ; F D IN,CHK Q:"^Q^NB^NP^"[(U_DDACT_U) Q ; IN K DDSBR,DDSFLD,DDSO,DDSU,DIR,DDSREPNT S:$D(@DDSREFS@(DDSPG,$S(DDO:DDSBK,1:0),DDO,"N"))#2 DDSU("N")=^("N") I DDM,'$G(DDSKM) D CLRMSG^DDS G:'DDO COM^DDSCOM ; S DDSOSV=0 F DDSI=0,1,2,4,7,10:1:14,20 D ;MOVE FIELD DEFINITION INTO DDSO ARRAY . S:$D(^DIST(.404,DDSBK,40,DDO,DDSI))#2 DDSO(DDSI)=^(DDSI) K DDSI ; S DDSFLD=$G(DDSO(1)) K DDSO(1) I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0,DDSFLD=DDO_","_DDSBK ; I DDSFLD]"",DDSDA]"" M DDSU=@DDSREFT@("F"_DDP,DDSDA,DDSFLD) ;Restore field's specs & value from ^TMP ; I '$D(DDSREP)!DDSDA,$$UNED($G(DDSU("A")),$G(DDSO(4)),$G(DDSU("N"))) D Q . I $D(DDSACT)#2 S DDACT=DDSACT K DDSACT . S:DDACT="U" DDACT="L" . S:DDACT="D" DDACT="R" . D CURSOR Q:$D(DDSBR)#2 . S DDSCHKQ=1 K DDSACT ; S (X,DDSOLD)=$G(DDSU("D")),DDSEXT=$G(DDSU("X"),X) ; X:$G(DDSO(11))'?."^" DDSO(11) ;PRE-ACTION I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2 I DDACT]"",$T(@DDACT)]"" D @DDACT S DDSCHKQ=1 Q ; S DIR0N=1 Q:DDSFLD="" ; S:$G(^DD(DDP,DDSFLD,0))'?."^" DDSU("DD")=^(0) I $D(DDSU("N"))[0 S DDACT="N" Q Q:$D(DDSO(2))[0 ; D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG() K DDSKM,DDQ ; S DIR0=$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,1,3) S:$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,10) $P(DIR0,U,6)=1 HITE S:$P($G(DDSREP),U,3)>1 $P(DIR0,U)=$P(DIR0,U)+($P(DDSREP,U,3)-1*$$HITE^DDSR(DDSBK)) ;DJW/GFT ; I $D(DDSREP),'DDSDA,$P(DDSO(0),U,3)'=2 K DDSU("DD") G SEL^DDSM I $D(DDSU("M"))#2 S DDSGL=U_$P(DDSU("M"),U,2) G:'DDSU("M") WP^DDSWP S DIR("B")=$G(DDSU("X"),DDSOLD) ; I $D(DDSU("M"))#2 D SEL^DDS5 G:X'=DDSOLD&(DDACT="N") EXT I $P($G(DDSO(0)),U,3)'=2 S DIR(0)=DDP_","_DDSFLD_"O" ;IT'S A FIELD-TYPE READ E D DIR^DDSFO D ^DIR K DIR,DUOUT,DIRUT,DIROUT ;DO THE READ! I DIR0N S (X,Y)=DDSOLD Q ; EXT I $E(X)=U!$D(DTOUT) S DIR0N=1 Q G EXT^DDS02 ; CHK Q:$D(DDSBR)#2 I $G(DDSCHKQ)=1 K DDSCHKQ Q G:$D(DTOUT) TO^DDS3 G:$E(X)=U UPA^DDS2 I $G(DDSFLD)=.01,X="",$G(DA),DDSOLD]"" G ^DDS6 ;DELETE ENTRY ; S %=$P($G(DDSU("DD")),U,5,99)["DINUM"!($P($G(DDSU("DD")),U,2)["I")!$S($P($G(DDSU("A")),U,4)="":$P($G(DDSO(4)),U,4),1:$P($G(DDSU("A")),U,4)) ;Is editing disabled? I $G(DDSFLD)]"",$G(DDSOLD)]"",X'=DDSOLD,% D I %["," S DDSDA=% D POSDA^DDSM(DDSDA,DDSOLD) K DDSCHKQ Q .N F,L .I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0,F="" F S F=$O(@DDSREFT@("F0",F)) Q:F="" D Q:%["," ..S L="" F S L=$O(@DDSREFT@("F0",F,L)) Q:L="" I +L=DDO,$P(L,",",2)=DDSBK,$P($G(@DDSREFT@("F0",F,L,"O")),X)="" S %=F Q ;FIND A MATCHING FORM-ONLY VALUE .I %'["," S F="" F S F=$O(@DDSREFT@("F"_DDP,F)) Q:F="" D Q:%["," ..I F'=DDSDA S L=$G(@DDSREFT@("F"_DDP,F,DDSFLD,"D")) I L]"",$P(L,X)="" S %=F ;FIND A MATCHING FIELD VALUE .S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD S:$D(DDSU("X"))#2 ^("X")=DDSU("X") . I 'DIR0N,$G(DDSFLD),$D(DDSU("M"))[0,$G(DDSCHKQ)'=2,% D Q ;He tried to change uneditable field (was UNED^DDS02) .S %=$P($G(DDSO(0)),U,2) I %="" S %=$P($G(DDSO(0)),U,5) ;GET CAPTION or UNIQUE NAME .D MSG^DDSMSG($$EZBLD^DIALOG(3090,%),1) ;'UNEDITABLE' .I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0 .S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD S:$D(DDSU("X"))#2 ^("X")=DDSU("X") ; K DDSCHKQ ; I $G(DDSFLD)=.01,$G(DDSPTB)]"",$G(DDSREP)<2,'DIR0N D RPF^DDS7(DDP,DDSPTB,DDSDA,.DA) I $G(DDSO(12))'?."^" X DDSO(12) ;POST ACTION ; I 'DIR0N,DDO,$G(DDSFLD)]"" D . I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0 . S DDSCHG=1 . I DDSDA!'$D(DDSREP),+$G(DDSU("F"))'=1 S $P(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"F"),U)=1 . I $G(DDSO(13))'?."^" X DDSO(13) ;POST ACTION ON CHANGE . D:$D(@DDSREFS@("PT",DDP,DDSFLD)) RPB^DDS7(DDP,DDSFLD,DDSPG) . D:$D(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG)) RPCF^DDSCOMP(DDSPG) ; I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2 Q:DDACT="" I $T(@DDACT)]"" G @DDACT I 'DDO G:X]"" ^DDS3 S DDSO(0)=0 I DDACT="D",$D(DDSREP),'DA S DDACT="N" ;GFT DON'T DOWN-ARROW THRU A MULTIPLE THAT HAS NO .01 FIELD DEFINED G:"^U^D^R^L^"[(U_DDACT_U) CURSOR G:$D(DDSU("M"))[0 NF G:DDSU("M") ^DDS5 D EDIT^DDSWP I '$D(DDGLCLR) S DDACT="Q" Q D R^DDSR ; NF I 'DDO,DDSOSV S DDO=DDSOSV Q ; I DDO,$S($D(DDSREP):DDSDA,1:1) D . D:'$D(DDSU("M")) .. I $G(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]"" S DDSSTACK="`"_^(DDO) ;ANOTHER PAGE HAS THIS FIELD AS ITS PARENT FIELD! .. E I $P($G(DDSO(7)),U,2)]"" S DDSSTACK=$P(DDSO(7),U,2) ;OR THERE IS A SUBPAGE LINK FROM THIS FIELD . X:$G(DDSO(10))'?."^" DDSO(10) ;BRANCHING LOGIC ; I $D(DDSSTACK) D:$G(^DIST(.403,+DDS,21400)) REFRESH^DDS02(DDSSTACK) D ^DDSSTK,R^DDS3 K DDSU ;WE DO A WHOLE RECURSION TO THE SUBPAGE, AND THEN REPAINT THIS PAGE I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2 S DDACT="N" ; CURSOR N ACT,B,BLK,BLK0,FND,N,REP K DDSACT S:$D(DDSU("N"))[0 DDSU("N")=$G(@DDSREFS@(DDSPG,DDSBK,DDO,"N")) S FND=0 I $D(DDSREP),DDO D MNAV^DDSM(.FND) Q:FND ; S B=U,(BLK,BLK0)=DDSBK,N=DDSU("N"),ACT=$S(DDO&$G(DDSDN):"N",1:DDACT) F D Q:FND!$D(REP) . S DDO=$P(N,U,$L($P("U^D^R^L^N",ACT),U)) . I 'DDO S (DDO,DDSBK)=0,FND=1 Q . ; . S DDSBK=$P(DDO,",",2),DDO=+DDO . I DDSBK D Q:$D(REP) .. I $P($G(@DDSREFS@(DDSPG,DDSBK)),U,4) D ... S DDO=$P($G(@DDSREFS@(DDSPG,DDSBK)),U,9),ACT="N" .. E S ACT=DDACT .. I '$P($G(@DDSREFT@(DDSPG,DDSBK)),U),DDSDAORG S B=B_DDSBK_U .. E I $P(@DDSREFS@(DDSPG,DDSBK),U,7)>1 S REP=1,DDACT="NB",DDSBR="" . E S DDSBK=BLK . ; . I B'[(U_DDSBK_U) S FND=1 S:DDSBK'=BLK0 DDACT="NB",DDSBR="",DDSACT=ACT . ; . S:'FND N=$G(@DDSREFS@(DDSPG,DDSBK,+DDO,"N")),BLK=DDSBK Q ; NP ;; G:$D(DDSREP)&DDO PGDN^DDSM ;If in REPEATING BLOCK S:DDSNP]"" DDSPG=DDSNP S:DDSNP="" DDACT="N" Q PP ;; G:$D(DDSREP)&DDO PGUP^DDSM ;If in REPEATING BLOCK S DDSPG=$$PP^DDS5(.Y) S DDACT=$S(Y=1:"NP",1:"N") Q NB ;; S DDSBK=$$NB^DDS5(.Y),DDACT=$S(Y=1:"NB",1:"N") Q SEL ;; ;I $G(DDSSEL) W $C(7) Q S DDACT="N" G PG^DDSRSEL SV ;; G SV^DDS02 QT ;; G QT^DDS3 EX ;; G EX^DDS3 CL ;; G CL^DDS3 MOUSE ;; G MOUSE^DDS2 PRNT ;; D ^DDSRP(+DDS,DDSPG) RF ;; S DDACT="N" I $G(^DIST(.403,+DDS,21400)) D REFRESH^DDS02(DDSPG) ;RE-DO THE DATA BEFORE REFRESHING PAGE G R^DDSR ; ; UNED(ATT,DEF,N) ; Q $S(N="":1,$P(ATT,U,4)="":$P(DEF,U,4)=1,1:$P(ATT,U,4)=1)&'$P(N,U,11) DDS02^INT^1^61069,61055^0 DDS02 ;SFISC/MKO-OVERFLOW FROM ^DDS01 ;24JUNE2007 ;;22.0;VA FileMan;**8,999,1003,1004,1028**;Mar 30, 1999 REFRESH(DDSPG) ;Refreshes the setup for page N B,D,I,DIE,DDSDA,DDP F B=0:0 S B=$O(@DDSREFT@(DDSPG,B)) Q:'B D .I '$D(DDSDA) S DDSDA=^(B),DIE=^(B,DDSDA,"GL"),DDP=$P(@DDSREFS@(DDSPG,B),U,3) ;GET THE ORIGINAL PAGE DATA .S D="" F S D=$O(@DDSREFT@(DDSPG,B,D)) Q:D="" I +$G(^(D))=1 S $P(^(D),U)=0 ;REMEMBER TO RELOAD BLOCKS ON THIS PAGE! .S I="" F S I=$O(@DDSREFT@("F0",I)) Q:I="" F S D=$O(@DDSREFT@("F0",I,D)) Q:D="" I $P(D,",",2)=B,$G(^(D,"F"))=3 K @DDSREFT@("F0",I,D) ;KILL OLD FORM-ONLY VALUE I $D(D) D ^DDS1(DDSPG) Q ; ; ; SV ;Save S DDACT="N" I $G(DDSDN)=1,DDO D ERR3^DDS3 Q I DDSSC'>1,'$P(DDSSC(DDSSC),U,4) D S^DDS3 Q ;INCLUDED '$G(DDSSEL) D MSG^DDSMSG($$EZBLD^DIALOG(3093),1) ;**CANNOT SAVE Q ; EXT ;Process external form I '$P($G(DDSU("DD")),U,2),$P($G(DDSU("DD")),U,2)["P" D PT I $P($G(DDSO(0)),U,3)=2,$E($P($G(DDSO(20)),U))="P" D PTFO ; S:DDSOLD=Y DIR0N=1 S DDSX=X,DDSY=Y I Y]"",$P($G(DDSU("DD")),U,2)["O",$G(^DD(DDP,DDSFLD,2))'?."^" K Y(0) X ^(2) S Y(0)=Y ; S DDSEXT=$G(Y(0,0),$G(Y(0),Y)),X=DDSY ; I $D(DDSO(14)) K DDSERROR X DDSO(14) I $D(DDSERROR)#2 D Q . K DDSERROR,DDSY S DIR0("L")=DDSEXT,DDSCHKQ=1 ; I DDSY="",DDSFLD'=.01 D Q:'$D(DDSY) . N DDSREQ,DDSKEY . S DDSREQ=$P($G(DDSU("A")),U) . S:DDSREQ="" DDSREQ=$P($G(DDSO(4)),U) . S:DDSREQ="" DDSREQ=$P($G(DDSU("DD")),U,2)["R" . S DDSKEY=$D(^DD("KEY","F",DDP,DDSFLD))>0 . I 'DDSREQ,'DDSKEY Q . K DDSY . S DDSCHKQ=1,DIR0("L")=DDSEXT . D MSG^DDSMSG($$EZBLD^DIALOG($S(DDSKEY:3092.2,1:3092.1)),1) ;'REQUIRED KEY FIELD' ; S DY=$P(DIR0,U),DX=$P(DIR0,U,2) REPNT I DDSEXT'=DDSX!$G(DDSREPNT) D K DDSREPNT ;WRITE OUT NEW VALUE, IF IT DIFFERS FROM WHAT WAS INPUT . X IOXY . S DDSX=$E(DDSEXT,1,$P(DIR0,U,3)) . I '$P(DIR0,U,6) S DDSX=DDSX_$J("",$P(DIR0,U,3)-$L(DDSEXT)) . E S DDSX=$J("",$P(DIR0,U,3)-$L(DDSEXT))_DDSX . W $P(DDGLVID,DDGLDEL)_DDSX_$P(DDGLVID,DDGLDEL,10) ; I $G(DDSU("K")),DDSY]""!(DDSFLD'=.01) D Q:'$D(DDSY) ;CHECK KEY . N DDSFXR,DDSUI,DDSUNIQ,DDSVSV,DIIENS . D LOADXREF^DIKC1(DDP,"","",DDSU("K"),"DEC^DDS02","DDSFXR") . S:$D(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D"))#2 DDSVSV=^("D") S ^("D")=DDSY . S DDSUNIQ=1,DDSUI=0 . F S DDSUI=$O(DDSFXR(DDP,DDSUI)) Q:'DDSUI D Q:'DDSUNIQ .. S DIIENS=DDSDA .. D SETXARR^DIKC(DDP,DDSUI,"DDSFXR") .. S DDSUNIQ=$$UNIQUE^DIKK2(DDP,DDSUI,.X,.DA,"DDSFXR") . I 'DDSUNIQ D .. K DDSY .. S DDSCHKQ=1,DIR0("L")=DDSEXT .. D MSG^DDSMSG($$EZBLD^DIALOG(3094),1) .. K @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D") S:$D(DDSVSV)#2 ^("D")=DDSVSV ; D:$G(DDSDA)!'$D(DDSREP) . S:$D(Y(0)) @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSEXT . S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSY I DDSY="",$D(DDSU("X")) S ^("X")="" ;CHANGE THE DATA! K DDSY Q ; DEC(FILE,FIELD,DEC) ; S DEC="S X=$G(@DDSREFT@(""F"_FILE_""",DIIENS,"_FIELD_",""D""),"_$E(DEC,5,999)_")" Q ; PT ;Modify Y for pointer type fields I $P(Y,U,3)=1 D . S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=+Y_","_U_$P(DDSU("DD"),U,3) S Y=$P(Y,U) Q ; PTFO ;Modify Y for pointer type form only fields I $P(Y,U,3)=1 D . N R,I S R="" . F I=1:1 Q:$D(DA(I))[0 S R=R_DA(I)_"," . S ^("ADD")=$G(@DDSREFT@("ADD"))+1,@DDSREFT@("ADD",@DDSREFT@("ADD"))=+Y_","_R_$S($P(DDSO(20),U,3):^DIC(+$P(DDSO(20),U,3),0,"GL"),1:U_$P($P(DDSO(20),U,3),":")) S Y=$S(Y=-1:"",1:$P(Y,U)) Q DDS1^INT^1^61069,61055^0 DDS1(DDSPG) ;SFISC/MKO-LOAD PAGE ;31MAY2007 ;;22.0;VA FileMan;**115,1003,1004,1028**;Mar 30, 1999 ;Input: ; DDS = Form number^Form name ; DDSPG = Internal page number ; DA = Record array ; DDSREFT = Global location where data (temporarily) is stored ; DDP = Primary file number of form ; DIE = Global root of form ; DDSDA = DA,DA(1),... of form ; DDSDL = Level number ;Also needed for pointed-to blocks: ; DDSDAORG ; DDSDLORG ;Returns: ; DIERR ; N DDS1B,DDS1BO K DDSMOUSE S U="^" ; ;Get header block S DDS1B=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,2) I DDS1B]"" D BLK(DDSPG,DDS1B,"",1) G:$G(DIERR) END ; ;Get all other blocks on page S DDS1BO="" F S DDS1BO=$O(^DIST(.403,+DDS,40,DDSPG,40,"AC",DDS1BO)) Q:DDS1BO="" S DDS1B=$O(^(DDS1BO,0)) Q:'DDS1B D BLK(DDSPG,DDS1B,DDS1BO) G:$G(DIERR) END ; END K DDSMOUSE Q ; BLK(DDSPG,DDS1B,DDS1BO,DDS1H,DDS1E) ;Load block ;In: DDS1H = 1 if a header block ; DDS1E = 1 if we're loading up a pointed-to block and ; we want interactive dialog (DIC(0)["E") in the lookup ; I $D(^DIST(.404,DDS1B,0))[0 D BLD^DIALOG(3051,"#"_DDS1B) Q ; N DDS1PTB,DDS1REP S DDS1PTB="" I '$G(DDS1H) D . S DDS1PTB=$G(^DIST(.403,+DDS,40,DDSPG,40,DDS1B,1)),DDS1REP=$G(^(2)) . K:DDS1REP<2 DDS1REP ; I DDS1PTB]"" N @$$D0(DDSDL),DA,DDP,DIE,DDSDL,DDSDA D Q:$G(DIERR) . I $G(DDS1REP)>1 D .. D BK^DDS10(.DDS1B,.DDP) Q:$G(DIERR) .. D GDA^DDS10(DDS1B,$G(DDS1E),.DA) Q:$G(DIERR) .. S DDP=$G(^DD(DDP,0,"UP"),DDP) ;GFT .. D GL^DDS10(DDP,.DA,.DIE,.DDSDL,.DDSDA,1) .. D GETD0(.DA,DDSDL) . E D .. D SET^DDS10(DDS1B,$G(DDS1E),.DA,.DDP,.DIE,.DDSDL,.DDSDA) ;GO GET THE NEW 'DA' VALUE .. I +$G(DIERR)=1,$G(^TMP("DIERR",$J,1))=601 D Q ... L -@(DIE_DA_")") ... K ^TMP("DDS",$J,"LOCK",DIE_DA_")") ... D CLEAN^DILF ... S (DA,D0,DDSDA)="" .. Q:$G(DIERR) .. I DA="",'$G(DDS1E),$P($G(@DDSREFT@(DDSPG,DDS1B)),U)]"" S DDSDA=$P(^(DDS1B),U),DA=+DDSDA .. S D0=DA ; I $G(DA)!'$G(DDSDAORG),$G(@DDSREFT@(DDSPG,DDS1B,DDSDA))<1 D . S $P(@DDSREFT@(DDSPG,DDS1B,DDSDA),U)=1 . I $G(DDS1REP)>1 D REP Q . ; . S @DDSREFT@(DDSPG,DDS1B,DDSDA,"GL")=DIE . D ^DDS11(DDS1B) ; S $P(@DDSREFT@(DDSPG,DDS1B),U)=$G(DDSDA) Q ; REP ;Load data for repeating block N DDS1DDP,DDS1IND,DDS1INI,DDS1MUL,DDS1PDA,DDS1REF,DDS1RT,DDS1SEL N DDS1SN,DDS1VAL,DDS1FSCR,DDS1SCNT,DDS1STRT,DDS1Q,DDS1ACT S DDS1REF=$NA(@DDSREFT@(DDSPG,DDS1B)) S DDS1DDP=$P(@DDSREFS@(DDSPG,DDS1B),U,3) S DDS1IND=$P(DDS1REP,U,2) S:DDS1IND="" DDS1IND="B" S DDS1INI=$P(DDS1REP,U,3) S DDS1SEL=$P(@DDSREFS@(DDSPG,DDS1B),U,10) S DDS1PDA=DDSDA ; S DDS1MUL=$O(^DD(+DDP,"SB",DDS1DDP,"")) S:$G(^DD(DDS1DDP,0,"SCR"))]"" DDS1FSCR=^("SCR") ACT S:$G(^("ACT"))]"" DDS1ACT=^("ACT") ; S $P(@DDS1REF@(DDS1PDA),U,7,10)=DDP_U_DDS1MUL_U_DDS1SEL_U_DDS1IND S @DDS1REF@(DDSDA,"GL")=$S(DDS1MUL:DIE_+DA_","""_$P($P(^DD(DDP,DDS1MUL,0),U,4),";")_""",",1:^DIC(DDS1DDP,0,"GL")) ; N DIE,DDP S DIE=@DDS1REF@(DDSDA,"GL"),DDS1RT=$$CREF^DILF(DIE),DDP=DDS1DDP S DDS1SN=0 ; I DDS1MUL D ;IT'S A MULTIPLE FIELD WITHIN TOP-LEVEL FILE . D DDA^DDS5(0,.DA,.DDSDL) . S DDSDA=","_DDSDA . S:'$D(@DDS1RT@(DDS1IND)) DDS1IND="!IEN" . I DDS1IND="!IEN" D .. S DA=0 F S DA=$O(@DDS1RT@(DA)) Q:'DA D REPLD . E D .. S (DDS1Q,DDS1STRT)=$NA(@DDS1RT@(DDS1IND)),DDS1SCNT=$QL(DDS1Q) .. F S DDS1Q=$Q(@DDS1Q) Q:DDS1Q="" Q:$NA(@DDS1Q,DDS1SCNT)'=DDS1STRT D ... S DA=$QS(DDS1Q,$QL(DDS1Q)) D REPLD ; GFT E I $G(^DIST(.403,+DDS,40,DDSPG,40,DDS1B,"COMP MUL"))]"" D S DDSDA=DDS1PDA,DA=+DDSDA,@DDS1REF@("COMP MUL")=$G(^DIST(.403,+DDS,40,DDSPG,40,DDS1B,"COMP MUL PTR")) ;COMPUTED MULTIPLE BUILDS A REPEATING BLOCK .N DICMX,D .I $G(^("COMP MUL PTR"))="" S DICMX="S DA=$G(D0,$G(D)) N D D NOFILE^DDS1" .E S DICMX="S DA=$G(D0,$G(D)) N D D REPLD^DDS1" .X ^("COMP MUL") ; E I $G(DA) S DDS1VAL=DA N D0,DA,DDSDA D ;IT'S A RELATIONAL JUMP (DA COULD BE UNDEFINED FOR AN UNRELATED FILE!) . S DDSDA="," . S (DDS1Q,DDS1STRT)=$NA(@DDS1RT@(DDS1IND,DDS1VAL)),DDS1SCNT=$QL(DDS1Q) . F S DDS1Q=$Q(@DDS1Q) Q:DDS1Q="" Q:$NA(@DDS1Q,DDS1SCNT)'=DDS1STRT D .. S DA=$QS(DDS1Q,$QL(DDS1Q)) D REPLD ; E S DIERR=1 Q ;Now set INITIAL POSITION DISV I DDS1INI="u" S DDS1INI="l" I $G(DUZ)]"",$G(DIE)]"" D I DDS1INI .N T .S T=$G(^DISV(DUZ,DIE)) Q:'T S T=$G(@DDS1REF@(DDS1PDA,"B",T_",")) Q:'T ;Get entry that SPACE-BAR would return .S DDS1SN=T,T=T-DDS1REP+1 .I T>0 S DDS1INI=T_U_(DDS1SN-T+1)_U_DDS1SN Q .S DDS1INI=1_U_DDS1SN_U_DDS1SN E I DDS1INI="l"!(DDS1INI="n") D . N N,T . S N=DDS1INI="n" F . S DDS1SN=$O(@DDS1REF@(DDS1PDA," "),-1)+N S:'DDS1SN DDS1SN=1 ;Don't want 1^0^0 . S T=DDS1SN-DDS1REP+2-N . S DDS1INI=$S(T<1:1_U_DDS1SN,1:T_U_(DDS1REP-'N))_U_DDS1SN E S DDS1INI="1^1^1" ; S $P(@DDS1REF@(DDS1PDA),U,2,6)=DDS1PDA_U_DDS1INI_U_+DDS1REP ; I DDS1MUL D . D UDA^DDS5(.DA,.DDSDL) . S DDSDA=$P(DDSDA,",",2,999) Q ; REPLD ;Load data Q:'$D(@DDS1RT@(DA,0)) I $D(DDS1FSCR) N Y S Y=DA X DDS1FSCR Q:'$T I $D(DDS1ACT) D .N DIC,Y .S DIC(0)="E",Y=DA_U_$P(@DDS1RT@(DA,0),U) .X DDS1ACT NOFILE S DDS1SN=DDS1SN+1,$P(DDSDA,",")=DA,@("D"_DDSDL)=DA S @DDS1REF@(DDS1PDA,DDS1SN)=DDSDA S @DDS1REF@(DDS1PDA,"B",DDSDA)=DDS1SN D ^DDS11(DDS1B) Q ; D0(DL) ;Given DL, return string D0,D1,...,Dn N I,S S S="" F I=0:1:DL S S=S_"D"_I_"," S:S?.E1"," S=$E(S,1,$L(S)-1) Q S ; GETD0(DA,DL) ;Given DA array, set D0,D1... N I S @("D"_DL)=DA F I=1:1:DL-1 S @("D"_(DL-I))=DA(I) Q DDS10^INT^1^60529,64859^0 DDS10 ;SFISC/MKO-BLOCK SETUP ;21SEP2006 ;;22.0;VA FileMan;**147,151**;Mar 30, 1999 ; SET(DDS1B,DDS1E,DA,DDP,DIE,DL,DDSDA) ;Get values for pointed-to block ;In: ; DDS1B = Block number or [Block name] (by ref) ; DDS1E = 1, if we're loading a pointed-to block and we want ; interactive dialog (DIC(0)["E") in the lookup ; DA = Record array ;Returns: ; DDS1B = Block number ; DDP = File number of block ; DIE = Global root based on DDP and DA ; DL = Level number (top=0) ; DDSDA = DA,DA(1),..., ; D BK(.DDS1B,.DDP) Q:$G(DIERR) D GDA(DDS1B,DDS1E,.DA) Q:$G(DIERR) D GL(DDP,.DA,.DIE,.DL,.DDSDA,$P($G(^DIST(.403,+DDS,40,+$G(DDSPG),40,DDS1B,0)),U,4)'="d") Q:$G(DIERR) ;Don't LOCK record if block is display-only Q ; BK(DDSBK,DDP) ;Lookup block, get file number ;Input: ; DDSBK = Block number or [Block name] (by ref) ;Returns: ; DDSBK = Block number ; DDP = File number ; DIERR ; I DDSBK=+$P(DDSBK,"E") D Q . I $D(^DIST(.404,DDSBK,0))[0 D BLD^DIALOG(3051,"#"_DDSBK) Q . S DDP=+$P(^DIST(.404,DDSBK,0),U,2) I DDSBK?1"["1.E1"]" D Q . N X,Y,DIC . S X=$E(DDSBK,2,$L(DDSBK)-1),DIC="^DIST(.404,",DIC(0)="FZ" . D ^DIC I Y<0 D BLD^DIALOG(3051,"named "_X) Q . S DDSBK=+Y,DDP=+$P(Y(0),U,2) D BLD^DIALOG(3051,"#"_DDSBK) Q ; GDA(DDS1B,DDS1E,DA) ;Find new DA ;Input: ; DDS1B = Block number ; DDS1E = 1:Interactive lookup ; DDSDAORG = Original DA array ; DDSDLORG = Original DL ; DDSPG ;Returns: ; DA = Record number ; DIERR ; N DDSDA,DDSI,X ; ;Set DA array to its original value S DA=DDSDAORG F DDSI=1:1:DDSDLORG S DA(DDSI)=DDSDAORG(DDSI) D DDSDA(.DA,DDSDLORG,.DDSDA) ; ;Xecute each PTB node F DDSI=1:1 Q:DA=""!'$D(@DDSREFS@(DDSPG,DDS1B,"PTB",DDSI)) X ^(DDSI) S:$G(X)'>0 DA="" ; ;Kill descendants of DA I '$G(DIERR) S DDSI=DA K DA S DA=DDSI S:DA'>0!$G(DIERR) DA="" Q ; GL(F,DA,DIE,DL,DDSDA,DDSL) ;Get global root, level, and IEN ;Input variables: ; F = file # ; DA = array ; DDSL = flag to lock record ;Returns: ; DIE = global root of file (null if error) ; DL = level (top=0) (null if error) ; DDSDA = IEN ; DIERR = Error flag ; I '$D(^DD(F)) D BLD^DIALOG(401,F) S (DIE,DL)="" Q I $D(^DIC(F,0,"GL"))#2 S DIE=^("GL"),DL=0 E D SUBGL Q:$G(DIERR) ; I '$G(DA) S DDSDA="0," Q D DDSDA(.DA,DL,.DDSDA) ; N DDSP S DDSP("FILE")=F,DDSP("IEN")=DDSDA ; I $D(@(DIE_DA_",0)"))[0 D BLD^DIALOG(601,"",.DDSP) I $D(@(DIE_DA_",-9)")) D BLD^DIALOG(602,"",.DDSP) ; I $G(DDSL),$D(^TMP("DDS",$J,"LOCK",DIE_DA_")"))[0 D Q:$G(DIERR) . D LOCK^DILF(DIE_DA_")") E D BLD^DIALOG(110,"",.DDSP) Q ;**147 . S ^TMP("DDS",$J,"LOCK",DIE_DA_")")="" Q ; SUBGL ;Get root and level for subfile N D,I,S,U1 S D=F F DL=0:1 Q:$D(^DD(D,0,"UP"))[0 S U1=^("UP") G:'$D(^DD(U1,"SB",D)) SUBER G:$D(^DD(U1,$O(^(D,"")),0))[0 SUBER S S(DL+1)=""""_$P($P(^(0),U,4),";")_"""",D=U1 G:$D(^DIC(D,0,"GL"))[0 SUBER S DIE=^("GL") F I=DL:-1:1 G:$D(DA(I))[0 SUBER S DIE=DIE_DA(I)_","_S(I)_"," Q ; SUBER ;Come here if an error is encountered in GL S (DIE,DL)="" D BLD^DIALOG(309) Q ; DDSDA(DA,DL,DDSDA) ;Determine DDSDA ;Input: ; DA = Record array ; DL = Level number (top=0) ;Output: ; DDSDA = DA,DA(1),..., ; N I I DA="" S DDSDA="" Q S DDSDA=DA_"," F I=1:1:DL S DDSDA=DDSDA_DA(I)_"," Q DDS11^INT^1^61069,61055^0 DDS11(DDSBK,DDSNFO) ;SFISC/MLH,MKO-LOAD DATA ;4JUNE2007; LOAD DATA TO BE SHOWN ON SCREEN ;;22.0;VA FileMan;**1005,151**;Mar 30, 1999 ;Input variables: ; DDSBK = Block # ; DDSPG = Page # (needed for form-only fields) ; DDSREFT = Temporary global location ; DDP = File number of block ; DIE = Global root of block ; DDSDA = DA,DA(1),... ; DDSNFO = Flag means don't reload form only fields ; N X,Y S DDS1REFD=$NA(@DDSREFT@("F"_DDP,DDSDA)) ; S DDS1FO=0 F S DDS1FO=$O(^DIST(.404,DDSBK,40,DDS1FO)) Q:'DDS1FO D LD ; I DDP,DDSDA S @DDS1REFD@("GL")=DIE ; K DDS1REFD,DDS1FLD,DDS1FO,DDS1KEY,DDS1LN,DDS1ND,DDS1PC,DDS1UI,DDS1DV K DDS1D1,DDS1D2,DDS1D3 Q ; LD ;Load data for a field ; ;Get form only fields I $P($G(^DIST(.404,DDSBK,40,DDS1FO,0)),U,3)=2,$P($G(^(20)),U)]"" D Q . Q:$G(DDSNFO) . N DDP . S DDP=0,DDS1FLD=DDS1FO_","_DDSBK . Q:"^1^3^"[(U_$G(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))_U) . S Y="" . I $D(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))[0,$G(^DIST(.404,DDSBK,40,DDS1FO,3))]"" D DEF(^(3),$G(^(3.1))) . S (@DDSREFT@("F0",DDSDA,DDS1FLD,"D"),^("O"))=Y ; ;Get DD fields S DDS1FLD=$G(^DIST(.404,DDSBK,40,DDS1FO,1)) Q:DDS1FLD?."^" Q:"^1^3^"[(U_$G(@DDS1REFD@(DDS1FLD,"F"))_U) ; S DDS1LN=$G(^DD(DDP,DDS1FLD,0)) Q:DDS1LN?."^" S DDS1PC=$P(DDS1LN,U,4),DDS1ND=$P(DDS1PC,";"),DDS1PC=$P(DDS1PC,";",2) S DDS1DV=$P(DDS1LN,U,2),X=$P(DDS1LN,U,3) ; D @($S(DDS1FLD=.001:"L3",DDS1PC=0:"L2",1:"L1")) ; I DDS1DV["O"!(DDS1DV["P")!(DDS1DV["V")!(DDS1DV["D")!(DDS1DV["S") D . Q:$D(@DDS1REFD@(DDS1FLD,"X")) . D:Y]"" XFORM . S @DDS1REFD@(DDS1FLD,"X")=Y ; I DDS1PC=0,DDS1DV,DDS1DV'["W",$D(@DDS1REFD@(DDS1FLD,"X"))[0 S ^("X")=Y Q ; L1 ;Get non-multiple field S DDS1LN=$G(@(DIE_"DA,DDS1ND)")) I $E(DDS1PC)'="E" S Y=$P(DDS1LN,U,DDS1PC) E S Y=$E(DDS1LN,+$E(DDS1PC,2,999),$P(DDS1PC,",",2)) S:Y?." " Y="" ; K @DDS1REFD@(DDS1FLD,"X") I Y="",$D(@DDS1REFD@(DDS1FLD,"F"))[0,$D(^DIST(.404,DDSBK,40,DDS1FO,3))#2 D DEF(^(3),$G(^(3.1))) MUMPS I $G(DUZ(0))'="@",DDS1DV["K" S $P(@DDS1REFD@(DDS1FLD,"A"),U,4)=1,Y=$TR($J("",$L(Y))," ","*") ;**151 S @DDS1REFD@(DDS1FLD,"D")=Y ; ;Get key info I '$D(@DDS1REFD@(DDS1FLD,"K")) D . S DDS1KEY=0 . F S DDS1KEY=$O(^DD("KEY","F",DDP,DDS1FLD,DDS1KEY)) Q:'DDS1KEY D .. S DDS1UI=$P(^DD("KEY",DDS1KEY,0),U,4) Q:'DDS1UI .. Q:$P($G(^DD("IX",DDS1UI,0)),U,6)'="F" .. S ^("K")=$G(@DDS1REFD@(DDS1FLD,"K"))_DDS1UI_U Q ; L2 ;Get multiple field S DDS1SUB=+$P(DDS1LN,U,2) Q:$D(^DD(DDS1SUB,.01,0))[0 S DDS1DV=DDS1SUB_$P(^DD(DDS1SUB,.01,0),U,2),X=$P(^(0),U,3) S DDS1DIC=DIE_DA_","""_DDS1ND_"""," ; D:DDS1DV'["W" . I $D(^DIST(.404,DDSBK,40,DDS1FO,3))#2 D D L22 .. D DEF(^DIST(.404,DDSBK,40,DDS1FO,3),$G(^(3.1)),1) .. S DDS1RN=$S($G(Y)="FIRST":$O(@(DDS1DIC_"0)")),$G(Y)="LAST":$O(@(DDS1DIC_""" "")"),-1),1:+$G(Y)) . E I $D(DUZ)#2,$L(DDS1DIC)<29,$D(^DISV(DUZ,DDS1DIC))#2 S DDS1RN=^(DDS1DIC) D L22 . E S DDS1RN=$S($D(@(DDS1DIC_"0)"))#2:$P(^(0),U,3),1:$O(^(0))) D L22 . E S (Y,@DDS1REFD@(DDS1FLD,"D"))="" ; S @DDS1REFD@(DDS1FLD,"M")=$S(DDS1DV["W":0,1:1)_DDS1DIC_U_DDS1SUB K DDS1DIC,DDS1RN,DDS1SUB Q L22 ; I DDS1RN>0,$D(@(DDS1DIC_+DDS1RN_",0)"))#2 S Y=$P(^(0),U),@DDS1REFD@(DDS1FLD,"D")=+DDS1RN Q ; DEF(DDS1LN3,DDS1LN31,DDS1MULT) ;Get default N DDS1PTR,DDS1OT Q:DDS1LN3="" I DDS1LN3'="!M" S Y=DDS1LN3 E I DDS1LN31'?."^" X DDS1LN31 S:$D(Y)[0 Y="" Q:Y=""!$G(DDS1MULT) ; K DIR I DDS1FLD["," D . S DIR(0)=$P(^DIST(.404,DDSBK,40,DDS1FO,20),U)_$P(^(20),U,2,3) . S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999) . I $E($P(DIR(0),U))="P" S DDS1PTR=1 E D . S DIR(0)=DDP_","_DDS1FLD . S DDS1PTR=$P($G(^DD(DDP,DDS1FLD,0)),U,2) . S DDS1OT=DDS1PTR["O",DDS1PTR=DDS1PTR["P" S DIR("V")="",(X,DIR("B"))=Y D ^DIR ; I DDER S Y="" I Y]"" D . I $G(DDS1PTR) S Y=$P(Y,U) . S $P(@DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"F"),U)=3 . I $G(DDS1PTR),$G(DDS1OT),$D(^DD(DDP,DDS1FLD,2))#2 K Y(0),Y(0,0) . S:$D(Y(0)) @DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"X")=$S($D(Y(0,0))#2:Y(0,0),1:Y(0)) . S DDSCHG=1 K DDER,DIR Q ; L3 ;Get number field S (@DDS1REFD@(.001,"D"),Y)=DA Q ; EXT(DDP,DDS1FLD,Y) ;Return external form of Y N DDS1DV,X S DDS1DV=$P(^DD(DDP,DDS1FLD,0),U,2),X=$P(^(0),U,3) I DDS1DV'["O",DDS1DV'["P",DDS1DV'["V",DDS1DV'["D",DDS1DV'["S" Q Y I DDS1DV'["O",Y="" Q "" D XFORM Q Y ; XFORM ; N DDS1N I DDS1DV["O",+DDS1FLD,$D(^DD(DDP,+DDS1FLD,2))#2 X ^(2) Q I DDS1DV["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) Q:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DDS1DV=$P(^(0),U,2) G XFORM I DDS1DV["V",+$P(Y,"E"),$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)"))#2 S X=+$P($P(^(0),U,2),"E") Q:$D(^(+$P(Y,"E"),0))[0 S Y=$P(^(0),U) I $D(^DD(+$P(X,"E"),.01,0))#2 S DDS1DV=$P(^(0),U,2),X=$P(^(0),U,3) G XFORM I DDS1DV["D" X ^DD("DD") I DDS1DV["S" D .I +DDS1FLD,$G(^DD(DDP,+DDS1FLD,0))[X S Y=$$SET^DIQ(DDP,+DDS1FLD,Y) ;FOREIGN-LANGUAGE SET VALUE .E D PARSET^DIQ(X,.Y) Q DDS2^INT^1^61069,61055^0 DDS2 ;SFISC/MLH-UP ARROW JUMP, BRANCH ;20JUNE2007 ;;22.0;VA FileMan;**999,1006,1011,1013,1028**;Mar 30, 1999 ; ; MOUSE ;Mouse has clicked: DDSMX=$X,DDSMY=$Y N DDSBO,P,DDS2O,% S DDACT="N",DDSMOUSY=1,DDS2O=DDO,DDSBO=DDSBK S X="" F S X=$O(DDSMOUSE(DDSMY,X)) Q:X=""!(X>DDSMX) S P=$O(DDSMOUSE(DDSMY,X,"")) I P'DX ;Click is to the left of Caption ..S S=^(2)+TOP-2 ;$Y OF THE FIRST MULTIPLE for this Field ..S S=DY-S+HITE/HITE Q:S<1!(S[".")!(S>REP) ;Can't click above or below the window ..I $D(@DDSREFT@(DDSPG,B,D,S+ABOVE)) S Z=S Q ;Z IS THE LINE MUST BE OFFSET BY NUMBER OF ONES ABOVE! ..I $P(@DDSREFS@(DDSPG,B),U,9)'=F Q ;Must go to 1st field of new multiple ..I S=1!$D(@DDSREFT@(DDSPG,B,D,S-1+ABOVE)) S Z=S Q $G(Z) ;Returns FIELD,BLOCK,PAGE,DDSCL ; DX(DY) F F=0:0 S F=$O(@DDSREFS@(DDSPG,B,F)) Q:'F I $D(^(F,"N")),+$G(^("D"))=DY D Q:$G(Z) .I $P(@DDSREFS@(DDSPG,B,F,"D"),U,2)+$P(^("D"),U,3)'>DX Q ;Click is to the right of data .I DX<$P(^("D"),U,2) Q:'$G(^DIST(.404,B,40,F,2)) S CAP=$P($P(^(2),U,3),",",2) Q:'CAP Q:CAP-1>DX ;Click is to the left of Caption .S Z=F_","_B_","_DDSPG Q ; NP ;from indirect GO in MOUSE+3, above S DDACT="NP" G NP^DDS01 ; ; UPA ;Up-arrow jump Q:$E(X)'=U I X?1"^"1.E,X'="^^",$G(DDSDN) D MSG^DDSMSG($$EZBLD^DIALOG(3096),1) Q ;** I X?1"^"1.E,X'="^^" D JMP Q ; ;Up-arrow only OUT I 'DDO D E^DDS3 Q I $D(DDSREP),DA D POSTACT D:$D(DDSBR)[0 END^DDSM Q I $G(DDSDN)=1 D MSG^DDSMSG($$EZBLD^DIALOG(3095),1) Q ;** D POSTACT S:$D(DDSBR)[0 DDSOSV=DDO,DDO=0 Q Q ; POSTACT ;Execute post action Q:$G(DDSO(12))?." " N X S X=$G(DDSOLD) X DDSO(12) D:$D(DDSBR)#2 BR Q ; JMP ;Up-arrow jump S DDS2X=X,X=$P(X,U,2) I X="" W $C(7) G KILL K DDH,DDQ S DDH=0 S (X,DDSX)=$$UPCASE($E(X,1,63)) ; ;Find exact matches D:$D(@DDSREFS@("CAP",X)) CAP D:$D(@DDSREFT@("XCAP",DDSPG,X)) XCAP ; ;Find partial matches S:X="?" (X,DDSX)="" F S DDSX=$O(@DDSREFS@("CAP",DDSX)) Q:DDSX=""!($P(DDSX,X)]"") D CAP S DDSX=X F S DDSX=$O(@DDSREFT@("XCAP",DDSPG,DDSX)) Q:DDSX=""!($P(DDSX,X)]"") D XCAP ; NO I 'DDH D MSG^DDSMSG($$EZBLD^DIALOG(3098,$P(DDS2X,U,2)),1) G KILL ;** S DDS2O=DDO I DDH=1 S DDO=$O(DDH(DDH,"")) E S DDD="J" D SC^DDSU DDO ;DDO=FIELD,BLOCK,PAGE S DDS2B=$P(DDO,",",2),DDS2P=$P(DDO,",",3),DDO=+DDO G:'DDS2B KILL ; S DDS2DA=DDSDA I DDS2P'=DDSPG D ;Different Page . D:'$D(@DDSREFT@(DDS2P,DDS2B)) ^DDS1(DDS2P) . S DDS2DA=@DDSREFT@(DDS2P,DDS2B) . I DDS2DA="" D .. D MSG^DDSMSG($C(7)_$P($T(ERR),";;",2)) .. S DDO=DDS2O . E D CKUNED D:'$G(DDS2UNED) .. D POSTACT .. S:$D(DDSBR)[0 DDACT="NP",DDSPG=DDS2P,DDSBK=DDS2B,DDSBR="" ;Set the new page ; E I DDS2B'=DDSBK D ;Different Block . S DDS2DA=@DDSREFT@(DDS2P,DDS2B) . I DDS2DA="" D .. D MSG^DDSMSG($C(7)_$P($T(ERR),";;",2)) .. S DDO=DDS2O . E I $P($G(@DDSREFS@(DDS2P,DDS2B)),U,4) D .. D MSG^DDSMSG($C(7)_$P($T(ERR1),";;",2)) .. S DDO=DDS2O . E D CKUNED D:'$G(DDS2UNED) .. D POSTACT .. S:$D(DDSBR)[0 DDACT="NB",DDSBK=DDS2B,DDSBR="" ;Set the new Block ; E D CKUNED D:'$G(DDS2UNED) . D POSTACT . S:$D(DDSBR)[0 DDACT="N" ; KILL S X=DDS2X K DDH,DDSI,DDSPGRP,DDSX K DDS2ATT,DDS2B,DDS2DA,DDS2F,DDS2O,DDS2P,DDS2UNED,DDS2X Q ; CKUNED ;Check uneditable status N DDP,DDSFLD ; I $P($G(^DIST(.404,DDS2B,40,+DDO,0)),U,3)=2 D . S DDP=0 . S DDSFLD=+DDO_","_DDS2B E D . S DDP=$P($G(@DDSREFS@(DDS2P,DDS2B)),U,3) . S DDSFLD=$P($G(^DIST(.404,DDS2B,40,+DDO,1)),U) I 'DDSFLD S DDS2UNED=1,DDO=DDS2O Q S DDS2ATT=$P($G(@DDSREFT@("F"_DDP,DDS2DA,DDSFLD,"A")),U,4) ; I DDO,$S(DDS2ATT="":$P($G(^DIST(.404,DDS2B,40,+DDO,4)),U,4)=1,1:DDS2ATT=1),'$P(@DDSREFS@(DDS2P,DDS2B,+DDO,"N"),U,11) D UNED .S DDS2UNED=$P(^DIST(.404,DDS2B,40,+DDO,0),U,2) I DDS2UNED="" S DDS2UNED=$P(^(0),U,5) I DDS2UNED="",$G(^(1)),$D(^DD(DDP,^(1),0)) S DDS2UNED=$P(^(0),U) .D MSG^DDSMSG($$EZBLD^DIALOG(3090,DDS2UNED),1) ;**FIELD is UNEDITABLE! .S DDS2UNED=1,DDO=DDS2O Q ; CAP ;Find all captions that match DDSX S DDSPGRP="" F S DDSPGRP=$O(@DDSREFS@("CAP",DDSX,DDSPGRP)) Q:DDSPGRP="" D . Q:U_DDSPGRP_U'[(U_DDSPG_U) . S DDS2P="" F S DDS2P=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P)) Q:'DDS2P D .. S DDS2B="" F S DDS2B=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B)) Q:'DDS2B D ... S DDS2F="" F S DDS2F=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B,DDS2F)) Q:'DDS2F D FILL Q ; XCAP ;Find all xecutable captions that match DDSX S DDS2P=DDSPG S DDS2B=0 F S DDS2B=$O(@DDSREFT@("XCAP",DDSPG,DDSX,DDS2B)) Q:'DDS2B D . S DDS2F=0 F S DDS2F=+$O(@DDSREFT@("XCAP",DDSPG,DDSX,DDS2B,DDS2F)) Q:'DDS2F D .. I $D(^DIST(.404,DDS2B,40,DDS2F,0))#2,$P(^(0),U,3)'=1 D FILL Q ; FILL ;Fill DDH array with possible choices S DDS2V=DDSX_$S($P(^DIST(.404,DDS2B,40,DDS2F,0),U,4)]"":" ("_$P(^(0),U,4)_")",1:"") S:DDS2P'=DDSPG DDS2V=DDS2V_" ("_$S($P($G(^DIST(.403,+DDS,40,DDS2P,1)),U)]"":$P(^(1),U),1:"Page "_$P(^(0),U))_")" S DDH=DDH+1,DDH(DDH,DDS2F_","_DDS2B_","_DDS2P)=DDS2V K DDS2V Q ; BR ;Evaluate DDSBR N B,B1,F,F1,P,P1,E,X Q:$D(DDSBR)[0 I DDSBR="QUIT" S DDACT="Q" Q ;** S P=$P($G(DDSOPB),U),B=$P($G(DDSOPB),U,2),F=$G(DDO),E=1 S:'B B=+$P(@DDSREFS@(+P,"FIRST"),",",2) S P1=$P(DDSBR,U,3),B1=$P(DDSBR,U,2),F1=$P(DDSBR,U) ; D @$S(P1]"":"PG",B1]"":"BK",1:"FD") S:'E DDACT=$S(P'=+DDSOPB:"NP",B'=$P(DDSOPB,U,2):"NB",1:"N"),DDSPG=P,DDSBK=B,DDO=F K:E DDSBR Q ; PG ; I P1=+$P(P1,"E") S P=$O(^DIST(.403,+DDS,40,"B",P1,"")) E S P=$O(^DIST(.403,+DDS,40,"C",$$UPCASE(P1),"")) Q:'P S:B1="" B1=$O(^DIST(.403,+DDS,40,P,40,"AC","")) Q:B1="" BK ; I B1=+$P(B1,"E") D . S B=$O(^DIST(.403,+DDS,40,P,40,"AC",B1,"")) E D . S B=$O(^DIST(.404,"B",B1,"")) Q:B="" . S B=$O(^DIST(.403,+DDS,40,P,40,"B",B,"")) Q:'B S:F1="" F1=$O(^DIST(.404,B,40,"B","")) FD ; Q:F1="" I F1="COM" S (E,F)=0 Q I F1=+$P(F1,"E") S X="B" E S F1=$$UPCASE(F1),X=$S($D(^DIST(.404,B,40,"D",F1)):"D",1:"C") S F=$O(^DIST(.404,B,40,X,F1,"")) S:F E=0 Q ; UPCASE(X) ; ;Return X in uppercase Q $$UP^DILIBF(X) ;** ; ERR ;;Unable to jump to that field. The block on which that field is located has no record associated with it. ; ERR1 ;;Unable to jump to that field. The block on which that field is located has navigation disabled. DDS3^INT^1^60300,29509^0 DDS3 ;SFISC/MLH-COMMAND UTILS ;16FEB2005 ;;22.0;VA FileMan;**999,1004,1006**;Mar 30, 1999 I $G(Y(0))]"","ECNRSPQ"[$E(Y(0)) D @$E(Y(0)) ;'Y' is carried over from the ^DIR read in DDSCOM Q ; S ;Save the form D ^DDS4,R^DDSR D:$D(DDSBR)#2 BR^DDS2 Q ; R ;Repaint all pages on current screen ;Called after wp, mults, and deletions G R^DDSR ; E ;Exit I DDSSC>1!'DDSCHG!$P(DDSSC(DDSSC),U,4) S DDACT="Q" Q S DDM=1 S Y=1 G EX ;S Y=0 I $G(^XTV(8989.5,0))?1"PARAM".E S Y=$$GET^XPAR("ALL","DI SCREENMAN DON'T ASK SAVE") I Y=1 G EX ;**AVOID THE Y/N QUESTION K DIR S DIR(0)="YO" S DIR("A")=$$EZBLD^DIALOG(8075) D BLD^DIALOG(9037,"","","DIR(""?"")") S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^3^"_(IOSL-1)_"^0" D ^DIR K DIR,DIROUT,DIRUT I Y=0!$D(DTOUT)!$D(DUOUT) D QT Q I Y="" S DDACT="N" Q I Y=1 D EX Q ; C ;Close S DDACT="Q" Q ; N ;Next page S:DDSNP]"" DDSPG=DDSNP,DDACT="NP" Q ; P ;Previous D PP^DDS01 Q ; Q ; QT ;Exit, don't save I $G(DDSDN)=1,DDO G ERR3 S DDACT="Q" I DDSSC>1!$P(DDSSC(DDSSC),U,4) D MSG1 Q ;IT ALSO QUIT HERE IF $G(DDSSEL) Q:'DDSCHG D DEL^DDS6 S DX=0,DY=IOSL-1 X IOXY W $P(DDGLCLR,DDGLDEL),$S($D(DTOUT):$$EZBLD^DIALOG(8076),1:"")_$$EZBLD^DIALOG(8077) H 1 Q ; EX ;Exit, save I $G(DDSDN)=1,DDO G ERR3 S DDACT="Q" I DDSSC>1!$P(DDSSC(DDSSC),U,4) D MSG1 Q ;IT ALSO QUIT HERE IF $G(DDSSEL) D ^DDS4 I 'Y S DDACT="N" D R D:$D(DDSBR)#2 BR^DDS2 Q ; CL ;Close I $G(DDSDN)=1,DDO G ERR3 G E ; TO ;Time-out I DDO,$G(DDSDN) S DDACT="N" G CURSOR^DDS01 I DDO S DDSOSV=DDO,DDO=0 E D E Q ; MSG1 ;Print closing page message S DX=0,DY=IOSL-1 X IOXY W $P(DDGLCLR,DDGLDEL)_"..." H 1 Q ; ERR3 ; D MSG^DDSMSG("Since navigation for the block is disabled, that key sequence is disabled.",1) S DDACT="N" Q ; ;#8075 Save changes before leaving form (Y/N)? ;#8076 Time out. ;#8077 Changes not saved! ;#9037 Enter 'Y' to save before exiting...(3 lines) DDS4^INT^1^60300,29509^0 DDS4 ;SFISC/MKO-FILE AND RELOAD ;9DEC2004 ;;22.0;VA FileMan;**11,1004,1009**;Mar 30, 1999 D ^DDS41 Q:Y'=1 N DA,DDO,DIE,DDP,DDSDA ; S DX=0,DY=IOSL-1 X IOXY W "Filing form"_$P(DDGLCLR,DDGLDEL) ; ;File data S DDS4FI="F" F S DDS4FI=$O(@DDSREFT@(DDS4FI)) Q:DDS4FI'?1"F".E D . S DDP=$E(DDS4FI,2,999),DDS4DA=" " . F S DDS4DA=$O(@DDSREFT@(DDS4FI,DDS4DA)) Q:DDS4DA="" D REC ; ;Reload all pages on form S DDS4P=0 F S DDS4P=$O(@DDSREFT@(DDS4P)) Q:'DDS4P D . S DDS4B=0 . F S DDS4B=$O(@DDSREFT@(DDS4P,DDS4B)) Q:'DDS4B D .. S DDP=$P(@DDSREFS@(DDS4P,DDS4B),U,3),DDSDA=" " .. F S DDSDA=$O(@DDSREFT@(DDS4P,DDS4B,DDSDA)) Q:'DDSDA D ... S $P(@DDSREFT@(DDS4P,DDS4B,DDSDA),U)=1,DIE=^(DDSDA,"GL") ... Q:$P(@DDSREFT@(DDS4P,DDS4B,DDSDA),U,6)>1 ... D GDA(DDSDA) ... D ^DDS11(DDS4B,1) ; I $G(^DIST(.403,+DDS,14))'?."^" D . I $G(DDSPTB)_$G(DDSREP)]"" N DIE,DDP,DDSDA,DA,DDSDL D .. S DA=DDSDAORG,DDSDL=DDSDLORG,DDSDA=DA_"," .. F DDSI=1:1:DDSDL S DA(DDSI)=DDSDAORG(DDSI),DDSDA=DDSDA_DA(DDSI)_"," .. S DDP=$P($G(DDSFLORG),U),DIE=U_$P($G(DDSFLORG),U,2) S:DIE=U DIE="" . X ^DIST(.403,+DDS,14) I '$G(DDSSAVE),$G(DDSPARM)["S" S DDSSAVE=1 S (Y,DDSH)=1,(DDSCHG,DX)=0,DY=IOSL-1 X IOXY W $P(DDGLCLR,DDGLDEL) K @DDSREFT@("ADD"),@DDSREFT@("RXR") K DIC,DDS1B,DDS1DA,DDS4B,DDS4DA,DDS4FI,DDS4FLD,DDS4FO,DDS4P K DDSEXT,DDSI,DDSINT,DDSLC,DDSLN,DDSND,DDSOND,DDSOLD,DDSP,DDSPC K DDSW,DDSX,DV Q ; ; REC ; G:DDS4FI="F0" FORMONLY ; S DIE=$G(@DDSREFT@(DDS4FI,DDS4DA,"GL")) I DIE="" Q ;JUST TO BE SAFE! D GDA(DDS4DA) S DDSOND=-1 K DDSLN S DDS4FLD="" F S DDS4FLD=$O(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD)) Q:DDS4FLD="" D FLD S:$D(DDSLN)#2 @(DIE_"DA,DDSND)")=DDSLN ; I $D(@DDSREFT@("RXR")) D . D FIRE^DIKC(DDP,.DA,"KS",$NA(@DDSREFT@("RXR")),"O^") . K @DDSREFT@("RXR") Q FLD ; Q:'$G(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"F")) S ^("F")="" I '$G(DDSCHANG),$G(DDSPARM)["C" S DDSCHANG=1 S DDSINT=$G(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"D")) ; ;Word processing fields (quit if multiple) I $D(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"M"))#2 D:'$P(^("M"),U) Q WP .N FR,TO,DDS4M .S DDS4M=^("M") . S FR=$NA(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"D")) . S TO=U_$$CREF^DILF($P(DDS4M,U,2)) .I $P($G(^DD(+$P(DDS4M,U,3),.01,0)),U,2)["a" D WP^DIET($E(DDS4FI,2,99),DDS4FLD,DDS4DA,TO) ;AUDIT Word -Processing . K @TO . M @TO=@FR . K @FR,@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"F") ; Q:$G(^DD(DDP,DDS4FLD,0))?."^" S DDSND=$P(^(0),U,4) S DDSPC=$P(DDSND,";",2) Q:"0 "[DDSPC S DDSND=$P(DDSND,";") ; I DDSOND'=DDSND D . S:$D(DDSLN)#2 @(DIE_"DA,DDSOND)")=DDSLN . S DDSLN=$G(@(DIE_"DA,DDSND)")) . S DDSOND=DDSND ; I DDSPC D . S DDSOLD=$P(DDSLN,U,DDSPC) . S $P(DDSLN,U,DDSPC)=DDSINT E D . S DDSW=$E(DDSPC,2,999),DDSP=$P(DDSW,",",2)+1 . S DDSOLD=$E(DDSLN,+DDSW,DDSP-1) . S DDSX=$E(DDSLN,DDSP,999) . S DDSLN=$E(DDSLN,1,DDSW-1)_$J("",DDSW-1-$L(DDSLN))_DDSINT . S:DDSX'?." " DDSLN=DDSLN_$J("",DDSP-DDSW-$L(DDSINT))_DDSX ; I $D(^DD(DDP,DDS4FLD,1))!($P(^(0),U,2)["a")!$D(^DD("IX","F",DDP,DDS4FLD)) D XR Q XR ; N DICRREC,DG,DP,DDS4AUD1,DDS4AUD2,DIANUM,DIIX,C,Y S DP=DDP,DDSOND=-1 I $D(DDSLN)#2 S @(DIE_"DA,DDSND)")=DDSLN K DDSLN S DICRREC="TRIG^DDS4" ; I $P(^DD(DDP,DDS4FLD,0),U,2)["a" D . S (DDS4AUD1,DDS4AUD2)=1 . I $G(^DD(DDP,DDS4FLD,"AUDIT"))["e",DDSOLD="" S DDS4AUD1=0 ; I DDSOLD]"" D . S DG=0 F S DG=$O(^DD(DDP,DDS4FLD,1,DG)) Q:DG<1 D .. S DIC=DIE,X=DDSOLD .. X:$D(^DD(DDP,DDS4FLD,1,DG,2))#2 ^(2) . I $G(DDS4AUD2) S DG=1,X=DDSOLD,DIIX="2^"_DDS4FLD D AUDIT^DIET ; I DDSINT]"" D . S DG=0 F S DG=$O(^DD(DDP,DDS4FLD,1,DG)) Q:DG<1 D .. S DIC=DIE,X=DDSINT .. X:$D(^DD(DDP,DDS4FLD,1,DG,1))#2 ^(1) . I $G(DDS4AUD1) S DG=1,X=DDSINT,DIIX="3^"_DDS4FLD D AUDIT^DIET Q:'$D(^DD("IX","F",DDP,DDS4FLD)) ; ;Process index file xrefs N DDSFXR,DDSFXREF,DDSRXREF D LOADFLD^DIKC1(DDP,DDS4FLD,"KS","",$NA(@DDSREFT@("F"))_"_","DDSFXR",$NA(@DDSREFT@("RXR")),.DDSFXREF,.DDSRXREF) I $G(DDSRXREF)]""!($G(DDSFXREF)]"") D . S @DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"O")=DDSOLD ;BRX-0404-11337 D:$G(DDSFXREF)]"" FIRE^DIKC(DDP,.DA,"KS","DDSFXR","O^") Q GDA(DDSDA) ; N I K DA S DA=$P(DDSDA,",") F I=2:1:$L(DDSDA,",")-1 S DA(I-1)=$P(DDSDA,",",I) Q ; FORMONLY ; N X D GDA(DDS4DA) S DDS4FLD="" F S DDS4FLD=$O(@DDSREFT@("F0",DDS4DA,DDS4FLD)) Q:DDS4FLD="" D . Q:'$G(@DDSREFT@("F0",DDS4DA,DDS4FLD,"F")) . S DDS4FO=$P(DDS4FLD,","),DDS4B=$P(DDS4FLD,",",2) . S DDSOLD=$G(@DDSREFT@("F0",DDS4DA,DDS4FLD,"O")),X=$G(^("D")),DDSEXT=$G(^("X"),X) . X:$G(^DIST(.404,DDS4B,40,DDS4FO,23))'?."^" ^(23) . S ^("O")=@DDSREFT@("F0",DDS4DA,DDS4FLD,"D"),^("F")="" Q ; TRIG ;Called from trigger logic (from DICR via DICRREC) N DDSRXREF D LOADFLD^DIKC1(DIH,DIG,"KS","",$NA(@DDSREFT@("F"))_"_","",$NA(@DDSREFT@("RXR")),"",.DDSRXREF) I $G(DDSRXREF)]"",'$D(@DDSREFT@("F"_DIH,DICRIENS,DIG,"O")) S ^("O")=DIU Q DDS41^INT^1^60300,29509^0 DDS41 ;SFISC/MKO-VERIFY DATA ;30JAN2004 ;;22.0;VA FileMan;**8,999,1004**;Mar 30, 1999 N DDO,DIERR N DDS4B,DDS4DA,DDS4DONE,DDS4ERR,DDS4FLD,DDS4OUT,DDS4PG,DDS4PG1,DDS4TP N DDSCAP,DDSERROR,DDSFDA,DDSI,DDSKEY,DDSPID,DDSREQ ; S DDS4OUT=$NA(@DDSREFT@("VALMSG")) S DDS4PG=DDSPG ; K @DDS4OUT,@DDSREFT@("MSG"),@DDSREFT@("KMSG") ; I $G(DDSPTB)_$G(DDSREP)]"" N DIE,DDP,DDSDA,DA,DDSDL D . S DA=+DDSDAORG,DDSDL=DDSDLORG,DDSDA=DA_"," ;GFT . F DDSI=1:1:DDSDL S DA(DDSI)=DDSDAORG(DDSI),DDSDA=DDSDA_DA(DDSI)_"," . S DDP=$P($G(DDSFLORG),U),DIE=U_$P($G(DDSFLORG),U,2) S:DIE=U DIE="" ; D LDALL I $G(DIERR) D G END . N P . S P(1)=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U),P(2)=$P($G(^(1)),U) . S:P(2)="" P(2)="unnamed" . D BLD^DIALOG(3041,.P),ERR^DDSMSG . S DDS4ERR=1 ; D LP ; ;Validate keys S DDSKEY=1 I $D(DDSFDA) D . S DDSKEY=$$KEYVAL^DIE("","DDSFDA",$NA(@DDSREFT@("KMSG"))) . I 'DDSKEY,$D(DDS4ERR)[0 S DDS4ERR=1 D BLD^DIALOG(3091,"","",DDS4OUT,"S") ; S DDSPG=DDS4PG I '$G(DDS4ERR),$G(^DIST(.403,+DDS,20))'?."^" X ^(20) I $G(@DDSREFT@("MSG"))>0!$G(DDS4ERR)!'DDSKEY D PRNT ; END S Y='$D(DDSERROR)&'$G(DDS4ERR)&$G(DDSKEY) ;BRX-0903-10662 K @DDS4OUT,@DDSREFT@("MSG"),@DDSREFT@("KMSG") Q ; LDALL ;Load all pages S DX=0,DY=IOSL-1 X IOXY W "..."_$P(DDGLCLR,DDGLDEL) ;**'PLEASE WAIT' S (DDSPG,DDS4PG1)=$O(^DIST(.403,+DDS,40,"B",$S($G(DDSPAGE)]"":DDSPAGE,1:1),"")) S Y=1 F D ^DDS1(DDSPG) Q:$G(DIERR) S DDSPG=$$NP^DDS5(.Y) Q:DDSPG=DDS4PG1!'Y Q ; LP ;Loop through all pages/blocks N DDP S DX=0,DY=IOSL-1 X IOXY W "..."_$P(DDGLCLR,DDGLDEL) ;**'VERIFYING' ; S DDSPG=0 F S DDSPG=$O(@DDSREFT@(DDSPG)) Q:'DDSPG D . S DDS4B=0 F S DDS4B=$O(@DDSREFT@(DDSPG,DDS4B)) Q:'DDS4B D .. Q:$D(DDS4DONE(DDS4B)) Q:$P(@DDSREFS@(DDSPG,DDS4B),U,5)'="e" .. S DDSPID=$S($P($G(^DIST(.403,+DDS,40,DDSPG,1)),U)]"":$P(^(1),U),1:"Page "_$P(^(0),U)) .. S DDS4DONE(DDS4B)="",DDP=$P(^DIST(.404,DDS4B,0),U,2) .. S DDO=0 F S DDO=$O(^DIST(.404,DDS4B,40,DDO)) Q:'DDO D VF Q ; VF ;Check required and key fields Q:$D(^DIST(.404,DDS4B,40,DDO,0))[0 S DDS4TP=$P(^(0),U,3) Q:DDS4TP=1 Q:DDS4TP=4 S DDSCAP=$P(^DIST(.404,DDS4B,40,DDO,0),U,2)_$S($P(^(0),U,4)]"":" ("_$P(^(0),U,4)_")",1:"") S DDSREQ=$P($G(^DIST(.404,DDS4B,40,DDO,4)),U) S DDSKEY=0 ; I DDS4TP=2 N DDP D . S DDP=0,DDS4FLD=DDO_","_DDS4B . S:DDSCAP="" DDSCAP=$P(^DIST(.404,DDS4B,40,DDO,0),U,5) ; E D Q:DDS4FLD'=+$P(DDS4FLD,"E") . S DDS4FLD=$G(^DIST(.404,DDS4B,40,DDO,1)) . I $G(^DD(DDP,DDS4FLD,0))?."^" S DDS4FLD="" Q . S:DDSCAP="" DDSCAP=$$LABEL^DIALOGZ(DDP,DDS4FLD) ;FOR SOME REASON, HE USED TO GRAB TITLE, IF PRESENT! . S:DDSREQ="" DDSREQ=$P(^DD(DDP,DDS4FLD,0),U,2)["R" . S DDSKEY=$D(^DD("KEY","F",DDP,DDS4FLD))>0 ; S DDS4DA=" " DAS F S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4DA)) Q:DDS4DA'["," D ;IGNORE "COMP MUL" NODE . I $P(@DDSREFT@(DDSPG,DDS4B,DDS4DA),U,6)<2 D VR Q . ; . N DDS4PDA S DDS4PDA=DDS4DA N DDS4DA . S DDS4DA="" . F S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4PDA,"B",DDS4DA)) Q:'DDS4DA D VR Q ; VR ;Check individual records I $P($G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"A")),U)]"" N DDSREQ S DDSREQ=$P(^("A"),U) I 'DDSREQ,'DDSKEY Q ; ;Required WP fields (quit if mult) I DDP,$D(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M")) D:'^("M") Q . N DDS4I,DDS4REF,DDS4VAL . I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"F")) S DDS4REF=$NA(^("D")) . E S DDS4REF=$P(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M"),U,2),DDS4REF=U_$E(DDS4REF,1,$L(DDS4REF)-1)_")" . S (DDS4VAL,DDS4I)=0 . F S DDS4I=$O(@DDS4REF@(DDS4I)) Q:'DDS4I I $G(@DDS4REF@(DDS4I,0))'?." " S DDS4VAL=1 Q . D:'DDS4VAL LDERR ; I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"D"))="" D LDERR Q ; I DDSKEY,$D(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"F")) S DDSFDA(DDP,DDS4DA,DDS4FLD)=$G(^("D")) Q ; LDERR ;Call ^DIALOG to load error N P,E I $D(DDS4ERR)[0 S DDS4ERR=1 D BLD^DIALOG(3091,"","",DDS4OUT,"S") ;'THE DATA COULD NOT BE FILED.' S P(1)=DDSPID,P(2)=DDSCAP I $L(DDS4DA,",")>2 E S E=$O(@DDSREFT@("F"_DDP,"")) I E]"" S E=$O(^(E)) I E]"" ;ARE THERE MORE THAN ONE OF THESE ENTRIES? I S P(3)=$$GET1^DIQ(DDP,DDS4DA,.01,,,"E") I P(3)]"" S P(3)="("_$$EZBLD^DIALOG(8079)_": "_P(3)_")" ;'SUBRECORD' D BLD^DIALOG(3092,.P,"",DDS4OUT,"S") ; '|1|, |2| is a required field |3|' Q ; PRNT ;Print messages N DDSABT S (DDSABT,DX,DY)=0 X IOXY W $P(DDGLCLR,DDGLDEL,2) S $X=0,$Y=0 ; ;Print required field messages I $G(DDS4ERR) S DDSI=0 F S DDSI=$O(@DDS4OUT@(DDSI)) Q:'DDSI D Q:DDSABT . D:$G(@DDS4OUT@(DDSI))]"" WLIN(^(DDSI)) ; ;Print duplicate key messages S DDSI=0 F S DDSI=$O(@DDSREFT@("KMSG","DIERR",DDSI)) Q:'DDSI D Q:DDSABT . D WLIN(" "),WLIN(@DDSREFT@("KMSG","DIERR",DDSI,"TEXT",1)) . Q:@DDSREFT@("KMSG","DIERR",DDSI)'=740 . ; . N DA,FIL,FILE,FLD,FLDS,FNAME,IENS,J,KEY,LEV,RNAME . S FILE=@DDSREFT@("KMSG","DIERR",DDSI,"PARAM","FILE"),IENS=$G(^("IENS")),KEY=$G(^("KEY")) . D FRNAME^DIKCU1(FILE,IENS,.FNAME,.RNAME,.LEV) . ; . I LEV D .. S FNAME=$J("",7)_"Subfile: "_FNAME D WLIN(.FNAME,16) .. S RNAME=$J("",8)_"Record: "_RNAME D WLIN(.RNAME,16) . ; . S FLDS="",J=0 F S J=$O(^DD("KEY",KEY,2,J)) Q:'J D .. Q:'$D(^DD("KEY",KEY,2,J,0)) S FLD=$P(^(0),U),FIL=$P(^(0),U,2) .. Q:'$D(^DD(FIL,FLD,0)) S FLDS=FLDS_$P(^(0),U)_" (#"_FLD_"), " . D:FLDS]"" WLIN(" Key Field(s): "_$E(FLDS,1,$L(FLDS)-2),16) ; ;Print developer messages S DDSI=0 F S DDSI=$O(@DDSREFT@("MSG",DDSI)) Q:'DDSI D Q:DDSABT . D:@DDSREFT@("MSG",DDSI)]"" WLIN(^(DDSI)) ; D EOP Q ; WLIN(DDSX,DDSINDNT) ;Write a single line, wrap at word boundaries N I D WRAP^DIKCU2(.DDSX,IOM-1-$G(DDSINDNT),IOM-1) S DDSX(0)=DDSX F I=0:1 Q:'$D(DDSX(I)) D Q:DDSABT . I $Y+4>IOSL D EOP I 'Y S DDSABT=1 Q . W !,$J("",$S(I:$G(DDSINDNT),1:0))_DDSX(I) Q EOP ;Issue EOP prompt N X S DX=0,DY=IOSL-1 X IOXY W $$EZBLD^DIALOG(8053) R X:DTIME ;** S Y=X'[U&$T I Y S (DX,DY)=0 X IOXY W $P(DDGLCLR,DDGLDEL,2) S $X=0,$Y=0 Q DDS5^INT^1^60300,29509^0 DDS5 ;SFISC/MKO-MULTS,NEXT/PREV PAGE,NEXT BLOCK ;9:53 AM 1 Oct 1999 ;;22.0;VA FileMan;**8**;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. I X="" D:DDSOLD="" NF^DDS01 D:DDSOLD]"" DM^DDS6 Q I DIR0N,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSGL,1,28))=$E(DDSGL,29,999)_X I $G(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]"" S DDS5PG=^(DDO) E I $P($G(DDSO(7)),U,2)="" D:X=DDSOLD NF^DDS01 Q D MULT,R^DDSR ; K DDSSTACK X:$G(^DIST(.404,DDSBK,40,DDO,10))'?."^" ^(10) I $D(DDSSTACK) D ^DDSSTK,R^DDS3 K DDSBR D:$D(DDSBR)#2 BR^DDS2 Q MULT ; N DIE,DDO,DDSBK,DDSDN,DDSNP,DDSOPB,DDSPG,DDSPTB,DDSREP,DDSTP ; I $G(DDS5PG) S DDSPG=DDS5PG K DDS5PG E D . S DDSPG(1)=$P($G(DDSO(7)),U,2) Q:DDSPG(1)="" . S DDSPG=$O(^DIST(.403,+DDS,40,"B",DDSPG(1),"")) Q:DDSPG="" Q:$D(^DIST(.403,+DDS,40,+$G(DDSPG),0))[0 N:'$P(^(0),U,6) DDSSC ; D DDA(Y,.DA,.DDSDL) I Y'=-1 D . N DDP,DDSDA,DDSFLD,DDSDLORG,DDSDAORG,DDSFLORG . S DIE=U_$P(DDSU("M"),U,2),DDP=$P(DDSU("M"),U,3) . S DDSDLORG=DDSDL,DDSDAORG=DA,DDSDA=DA_"," . F DDSI=1:1:DDSDL S DDSDAORG(DDSI)=DA(DDSI),DDSDA=DDSDA_DA(DDSI)_"," . K DDSI . S DDSSTK=1 . D PROC^DDS D LST(.DA,.DDSDL,DDP,DDSDA,DDSFLD) D UDA(.DA,.DDSDL) Q ; LST(DA,DDSDL,DDP,DDSDA,DDSFLD) ;Save last edited subrecord ;In: DA array, DDSDL at subfile level ; DDP, DDSDA, DDSFLD at file level N DDSDIE,Y S DDSDIE=U_$P(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"M"),U,2) I $D(@(DDSDIE_"+$G(DA),0)"))[0 D . S DA=$S($D(@(DDSDIE_"0)"))#2:$P(^(0),U,3),1:$O(^(0))) . I DA>0 D .. N C .. S Y=$P(@(DDSDIE_DA_",0)"),U) .. S C=$P(^DD(+$P(^DD(DDP,DDSFLD,0),U,2),.01,0),U,2) .. D Y^DIQ . E S (DA,Y)="" E S (DA,Y)="" I DA>0,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSDIE,1,28))=$E(DDSDIE,29,999)_DA ; S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=Y,^("D")=DA,DDACT="N" Q ; SEL ;Issue the read at the Select mult prompt S DIR(0)="PO"_DDSGL_":QEMZ"_$E("L",'$D(DDSTP)&'$P($G(DDSO(4)),U,5))_$E("V",$P($G(DDSO(4)),U,6)) I $D(@(DDSGL_"0)"))[0 S ^(0)=U_$P($G(DDSU("DD")),U,2)_U_U E I $P(@(DDSGL_"0)"),U,2)'=$P($G(DDSU("DD")),U,2) S $P(^(0),U,2)=$P($G(DDSU("DD")),U,2) D DDA(0,.DA,.DDSDL) S DDSDA="0,"_DDSDA D ^DIR K DIR,DUOUT,DIRUT,DIROUT D UDA(.DA,.DDSDL) S DDSDA=$P(DDSDA,",",2,999) Q:DDACT'="N" ; I DIR0N S (X,Y)=DDSOLD Q I $P(Y,U,3)=1 S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=+Y_","_DDSDA_DDSGL E S DIR0N=1 S Y=$P(Y,U) S:X="" Y="" Q ; DDA(Y,DA,DL) ;Push Y onto DA array N I F I=DL:-1:1 S DA(I+1)=DA(I) S DA(1)=DA,DL=DL+1 S (DA,@("D"_DL))=$S(+$P($G(Y),"E"):+$P(Y,"E"),1:0) Q ; UDA(DA,DL) ;Pop DA array N I S DA=DA(1) F I=2:1:DL S DA(I-1)=DA(I) K DA(DL),@("D"_DL) S DL=DL-1 Q NP(Y) ;Returns: Next page ; (Y=1 if found, 0 if not found) N P,P1 S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,4) I P1]"" D . S P=$O(^DIST(.403,+DDS,40,"B",P1,"")) . I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1 Q $S(Y=1:P,1:DDSPG) PP(Y) ; N P,P1 S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,5) I P1]"" D . S P=$O(^DIST(.403,+DDS,40,"B",P1,"")) . I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1 Q $S(Y=1:P,1:DDSPG) NB(Y) ; N B,BO,X S (B,Y)=0,BO=$P($G(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,0)),U,2) I BO F D Q:B=DDSBK!Y . S BO=$O(^DIST(.403,+DDS,40,DDSPG,40,"AC",BO)) S:'BO BO=$O(^("")) S B=$O(^(BO,"")) . S X=$G(@DDSREFS@(DDSPG,B)) . I $P(X,U)]"",$P(X,U,5)'="h",$P(X,U,9),B'=DDSBK S Y=1 Q B DDS6^INT^1^60300,29509^0 DDS6 ;SFISC/MKO-DELETIONS ;14NOV2003 ;;22.0;VA FileMan;**1003**;Mar 30, 1999 ;Enter here if user deleted record from the .01 of the (sub)record ;(called from DDS01) ;In: DDSU array, DDSOLD, DDSFLD D D I 'Y D ;DELETE DIDN'T HAPPEN . S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD . S:$D(DDSU("X"))#2 @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSU("X") E D . I $D(DDSREP) D .. D DEL^DDSM1(DDSDA) ;THIS WILL COME BACK TO K IN THIS ROUTINE! . E D K(DDSDA,DIE) I $D(DDSPTB) D .. S DDACT="NB" .. S $P(@DDSREFT@(DDSPG,DDSBK),U)="" .. D DB^DDSR(DDSPG,DDSBK) .. D RPF^DDS7(DDP,DDSPTB,DDSDA,.DA) . E S DDACT="Q",DA="",DDSDAORG=DA,DDSDA="0," . I '$D(DDSPTB),'$P(DDSSC(DDSSC),U,4),'$D(DDSREP) D .. D PG^DDSRSEL .. I $G(DDSSEL) D ... D CLRDAT^DDSRSEL ... D R^DDSR ... D PUT^DDSVALF(1,1,$P(^DIST(.403,+DDS,21),U),"","","0,") Q ; DM ;Enter here if user deleted record from the Select prompt ;(called from DDS5) ;In: DDSU array, DDSOLD, DDSFLD ; ;Get DA and DIE for subfile level and delete D DDA^DDS5(DDSOLD,.DA,.DDSDL) D . N DIE,DDSDA . S DIE=U_$P(DDSU("M"),U,2) . S DDSDA=DA_"," F DDSI=1:1:DDSDL S DDSDA=DDSDA_DA(DDSI)_"," . K DDSI . D D . D:Y K(DDSDA,DIE) ; I 'Y D . S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD . S:$D(DDSU("X"))#2 @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSU("X") . D UDA^DDS5(.DA,.DDSDL) E D . D LST^DDS5(.DA,.DDSDL,DDP,DDSDA,DDSFLD) . D UDA^DDS5(.DA,.DDSDL) Q ; D ;Delete the subrecord ;In: DA array, DIE, DDSDL; Out: Y=1 if successful N DR,DDS6DA,DDSI D:DDM CLRMSG^DDS S DDM=1 ; K DIR S DIR(0)="YO" D BLD^DIALOG(8080,$$EZBLD^DIALOG(8078+(DDSDL>0)),"","DIR(""A"")") D BLD^DIALOG(9038,"","","DIR(""?"")") ; S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^3^"_(IOSL-3)_"^0" D ^DIR K DIR D CLRMSG^DDS I X=""!$D(DIRUT)!'Y S Y=0 K DIRUT,DUOUT,DIROUT,DTOUT Q ; S DDS6DA=DA N D0 F DDSI=1:1 Q:$D(DA(DDSI))[0 S DDS6DA(DDSI)=DA(DDSI) N @("D"_DDSI) W $P(DDGLVID,DDGLDEL,9) S X=IOM X $G(^%ZOSF("RM")) S DR=".01///@" D ^DIE K DI ;DELETE THE SUB-RECORD! W $P(DDGLVID,DDGLDEL,8) S X=0 X ^%ZOSF("RM") ; ;I $D(DA) H 2 W $P(DDGLCLR,DDGLDEL,2) D R^DDSR S Y=0 Q I $D(DA) S:$Y>(DDSHBX+1) DDSKM=1,DDM=1 S Y=0 Q ; S Y=1,DA=DDS6DA I '$G(DDSCHANG),$G(DDSPARM)["C" S DDSCHANG=1 F DDSI=1:1 Q:$D(DDS6DA(DDSI))[0 S DA(DDSI)=DDS6DA(DDSI) Q ; K(DDSIEN,DIE) ;Remove all data pertaining to the (sub)record from @DDSREFT ;In: DDSIEN = IENS of record being deleted ; DIE = global root ; N B,P,FN,PAT,PDA,IENS S PAT=".E1"""_DDSIEN_"""" ; ;Loop through all pages/blocks in ^TMP S P=0 F S P=$O(@DDSREFT@(P)) Q:'P D . S B=0 F S B=$O(@DDSREFT@(P,B)) Q:'B D .. ;Get file number of the block .. S FN="F"_$P(@DDSREFS@(P,B),U,3) .. ; .. ;Loop through all records loaded for that block .. S IENS=" " B .. F S IENS=$O(@DDSREFT@(P,B,IENS)) Q:IENS'["," D ... ; ... ;If the data pertains to the current or ancestor file, kill it ... ;Get the parent IENS (also indicates the block is repeating) ... S PDA=$P($G(@DDSREFT@(P,B,IENS)),U,2) ... ; ... I 'PDA,IENS?@PAT,$P(@DDSREFT@(P,B,IENS,"GL"),DIE)="" D .... K @DDSREFT@(P,B,IENS) .... K @DDSREFT@(FN,IENS) SUB ... E I $P($G(@DDSREFT@(P,B,IENS)),U,6)!PDA,@DDSREFT@(P,B,IENS,"GL")=DIE D ;IF IT'S A MULTIPLE IN A REPEATING BLOCK .... D DELP(P,B,PDA,DDSIEN) .... K @DDSREFT@(FN,DDSIEN) Q ; DELP(P,B,PDA,IENS) ;Delete subrecord from parent's list ;In: P = page number ; B = block number ; PDA = parent IENS ; IENS = IENS of record to remove N R,S ; S S=$G(@DDSREFT@(P,B,PDA,"B",IENS)) Q:'S K @DDSREFT@(P,B,PDA,"B",IENS) ; F S=S:1 Q:$D(@DDSREFT@(P,B,PDA,S+1))[0 D . S R=@DDSREFT@(P,B,PDA,S+1) . S @DDSREFT@(P,B,PDA,S)=R . S @DDSREFT@(P,B,PDA,"B",R)=S K @DDSREFT@(P,B,PDA,S) Q ; DEL ;Delete (sub)records added between saves ;(user quit without saving) N DA,DIK S DDSI=0 F S DDSI=$O(@DDSREFT@("ADD",DDSI)) Q:'DDSI D . K DA . S DA=$P(@DDSREFT@("ADD",DDSI),U),DIK=U_$P(^(DDSI),U,2) . F DDSX=2:1:$L(DA,",")-1 S DA(DDSX-1)=$P(DA,",",DDSX) . S DA=+DA . D ^DIK K DDSI,DDSX Q ;#8078 record ;#8079 subrecord ;#8080 WARNING: DELETIONS ARE DONE... ;#9038 Enter 'Y' to delete... DDS7^INT^1^60300,29509^0 DDS7 ;SFISC/MKO-Relational ;1:39 PM 28 Jun 1996 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. RPB(DDP,DDSFLD,DDSPG) ;Repaint pointed-to block(s) recursively N DDS7B S DDS7B="" F S DDS7B=$O(@DDSREFS@("PT",DDP,DDSFLD,DDSPG,DDS7B)) Q:DDS7B="" D . N DDP,DDSFLD . I $P($G(@DDSREFS@(DDSPG,DDS7B)),U,8) D .. D BLK^DDS1(DDSPG,DDS7B,"","",1) .. D DB^DDSR(DDSPG,DDS7B) . S DDP=$P($G(@DDSREFS@(DDSPG,DDS7B)),U,3) . D:$D(@DDSREFS@("PT",DDP)) .. S DDSFLD="" .. F S DDSFLD=$O(@DDSREFS@("PT",DDP,DDSFLD)) Q:DDSFLD="" D ... D:$D(@DDSREFS@("PT",DDP,DDSFLD,DDSPG)) RPB(DDP,DDSFLD,DDSPG) Q ; RPF(DDP,DDSPTB,DDSDA,DA) ;Repaint and update pointer field of ;pointer blocks because user changed the .01 value S DDS7V=$G(@DDSREFT@("F"_DDP,DDSDA,.01,"D")) I DDS7V]"",$D(^("X"))#2 S DDS7V=^("X") S DDS7DAS=U_DA_U F DDS7I=$L(DDSPTB,U):-1:1 D Q:$G(DDS7FD)'=.01 . S DDS7PTB=$P(DDSPTB,U,DDS7I) . D:DDS7PTB]"" RPF1 K DDS7B,DDS7D,DDS7DA,DDS7DAS,DDS7DAST,DDS7DDO,DDS7FD,DDS7FI K DDS7I,DDS7L,DDS7PTB,DDS7REF,DDS7RJ,DDS7V,DDS7X Q RPF1 ; I DDS7PTB[";J" S DDS7FD="" Q S DDS7PTB=$P(DDS7PTB,";") I $L(DDS7PTB,",")=2 S DDS7FI=+DDS7PTB,DDS7FD=$P(DDS7PTB,",",2) E I $L(DDS7PTB,",")=3 S DDS7FI=0,DDS7FD=$P(DDS7PTB,",",2,3) E Q Q:DDS7FI=""!(DDS7FD="") ; ;Repaint pointer field on current page S DDS7B="" F S DDS7B=$O(@DDSREFS@("F"_DDS7FI,DDS7FD,"L",DDSPG,DDS7B)) Q:DDS7B="" D . S DDS7DDO="" . F S DDS7DDO=$O(@DDSREFS@("F"_DDS7FI,DDS7FD,"L",DDSPG,DDS7B,DDS7DDO)) Q:DDS7DDO="" D .. Q:$G(@DDSREFS@(DDSPG,DDS7B,DDS7DDO,"D"))="" S DY=+^("D"),DX=$P(^("D"),U,2),DDS7L=$P(^("D"),U,3),DDS7RJ=$P(^("D"),U,10) .. X IOXY .. S DDS7X=$P(DDGLVID,DDGLDEL)_$E(DDS7V,1,DDS7L)_$P(DDGLVID,DDGLDEL,10) .. W $S(DDS7RJ:$J(" ",DDS7L-$L(DDS7V))_DDS7X,1:DDS7X_$J(" ",DDS7L-$L(DDS7V))) ; ;Reset external form of pointer data. ; ;If the pointer field is the .01, then we may have to follow back ;to pointers that point to this pointer block. ; ;DDS7DAS initially contains a list of records whose .01s we changed. ;DDS7DAST keeps a running list of all records in the pointer block ;that we change. ;DDS7DAS is finally set to this running list, so that when we go ;to update the pointer to the pointer block, we know which pointers ;to update. ; S DDS7DAST="",DDS7DA=" " F S DDS7DA=$O(@DDSREFT@("F"_DDS7FI,DDS7DA)) Q:DDS7DA'["," D . S DDS7REF=$NA(@DDSREFT@("F"_DDS7FI,DDS7DA,DDS7FD)) . S DDS7D=$G(@DDS7REF@("D")) . I DDS7DAS[(U_$P(DDS7D,";")_U),$S(DDS7D[";":U_$P(DDS7D,";",2)=DIE,1:1) D .. I DDS7V="",DDS7FD'=.01 S @DDS7REF@("D")="",^("F")=3 .. S:$D(@DDS7REF@("X"))#2 ^("X")=$S(DDS7V=""&(DDS7FD=.01):@DDS7REF@("D"),1:DDS7V) .. I DDS7FD=.01,DDS7DAST_U'[(U_+DDS7DA_U) S DDS7DAST=DDS7DAST_U_+DDS7DA S DDS7DAS=DDS7DAST_U Q DDSBOX^INT^1^60300,29509^0 DDSBOX(DDSUL,DDSLR) ;SFISC/MKO-DRAW A BOX ;08:17 AM 9 Apr 1993 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. D BOUNDS Q:'Y ; S DDS3L="" S $P(DDS3L,$P(DDGLGRA,DDGLDEL,3),$P(DDSLR,",",2)-$P(DDSUL,",",2))="" S DDS3M=$P(DDGLGRA,DDGLDEL,4)_$J("",$P(DDSLR,",",2)-$P(DDSUL,",",2)-1)_$P(DDGLGRA,DDGLDEL,4) ; S DY=$P(DDSUL,",")-1,DX=$P(DDSUL,",",2)-1 X IOXY W $P(DDGLGRA,DDGLDEL)_$P(DDGLGRA,DDGLDEL,5)_DDS3L_$P(DDGLGRA,DDGLDEL,6) ; F DY=$P(DDSUL,","):1:$P(DDSLR,",")-2 D . S DX=$P(DDSUL,",",2)-1 X IOXY . W DDS3M ; S DY=$P(DDSLR,",")-1,DX=$P(DDSUL,",",2)-1 X IOXY W $P(DDGLGRA,DDGLDEL,7)_DDS3L_$P(DDGLGRA,DDGLDEL,8)_$P(DDGLGRA,DDGLDEL,2) ; K DDS3L,DDS3M Q ; CLEAR(DDSUL,DDSLR) ;Clear area within upper left and lower right coords N S D BOUNDS Q:'Y ; S S=$J("",$P(DDSLR,",",2)-$P(DDSUL,",",2)+1) S DX=$P(DDSUL,",",2)-1 F DY=$P(DDSUL,",")-1:1:$P(DDSLR,",")-1 X IOXY W S Q ; BOUNDS ;Make sure area is within acceptable boundaries N DDSV,DDSP S Y=1 I $G(DDSUL)=""!($G(DDSLR))="" S Y=0 Q ; F DDSV="DDSUL","DDSLR" D . S:$P(@DDSV,",")>DDSHBX $P(@DDSV,",")=DDSHBX . S:$P(@DDSV,",",2)>(IOM-1) $P(@DDSV,",",2)=IOM-1 . F DDSP=1,2 S:$P(@DDSV,",",DDSP)<1 $P(@DDSV,",",DDSP)=1 ; I $P(DDSLR,",")-$P(DDSUL,",")<2 S Y=0 Q I $P(DDSLR,",",2)-$P(DDSUL,",",2)<2 S Y=0 Q ; Q DDSCAP^INT^1^60300,29509^0 DDSCAP ;SFISC/MKO-INPUT TRANSFORM FOR CAPTIONS ;01:24 PM 14 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 ; FUNC(X) ; Q:$E(X)'="!" N E,F,Y S F=$E(X,2,999) S:$P(F,"(")?.A1.L.A F=$$UPCASE($P(F,"("))_$S(F["(":"("_$P(F,"(",2,999),1:"") Q:$P(F,"(")'?1U.7UN X Q:$T(@$P(F,"("))="" X ; D Q:$G(E) X . N X S X="S Y=$$"_F . N F D ^DIM . S:'$D(X) E=1 ; S @("Y=$$"_F) Q Y ; L() ;;Get label of field N F1,F2 S X="" S F1=$$GET^DDSVAL(DIE,.DA,4) Q:'F1 X S F2=$$GET^DDSVAL(.404,DA(1),1) Q:'F2 X S X=$P($G(^DD(F2,F1,0)),U) Q X ; T() ;;Get title of field N F1,F2 S X="" S F1=$$GET^DDSVAL(DIE,.DA,4) Q:'F1 X S F2=$$GET^DDSVAL(.404,DA(1),1) Q:'F2 X S X=$G(^DD(F2,F1,.1)) Q X ; U() ;;Get unique name of field Q $$GET^DDSVAL(DIE,.DA,3.1) ; DUP(X1,X) ;;The DUP function Q:$G(X1)="" "" N % S %=X,X="",$P(X,X1,%\$L(X1)+1)=X1,X=$E(X,1,%) Q X ; UPCASE(X) ;Convert X to uppercase Q $$UP^DILIBF(X) ;** DDSCLONE^INT^1^60300,29509^0 DDSCLONE ;SFISC/MKO-CLONE A FORM ;2OCT2003 ;;22.0;VA FileMan;**999,1003**;Mar 30, 1999 N %,%CHK,%RET,%X,%Y,D,D0,D1,DA,DI,DIOVRD,DIC,DIR,DIZ,DQ,DREF,X,Y K ^TMP("DDSCLONE",$J) S DDSQUIT=0,DIOVRD=1 ; S DDSFORM=$$FORM G:DDSFORM=-1 QUIT ; D GETBLKS D REPORT G:DDSQUIT QUIT D RENMSP G:DDSQUIT QUIT D RENAME G:DDSQUIT QUIT D ^DDSCLONF DONE I '$G(DDSQUIT) W !!!,"DONE!" ; QUIT ;Cleanup K ^TMP("DDSCLONE",$J) K DDSBK,DDSBKDA,DDSFILE,DDSFORM,DDSNFRM,DDSNNS,DDSONS,DDSQUIT K DDH,DIRUT,DIROUT,DTOUT,DUOUT Q ; FORM() ;Prompt for form ;Select file N D,DIC EGP S DDS1=8108 D W^DICRW K DDS1 G:Y<0 FORMQ ;**CCO/NI 'CLONE FORM' I '$D(@(DIC_"0)")) S Y=-1 G FORMQ S DDSFILE=Y ; ;Select form W ! K DIC S DIC="^DIST(.403,",DIC(0)="QEAM" S DIC(0)="QEA",D="F"_+DDSFILE S DIC("S")="I $P(^(0),U,8)=+DDSFILE" S DIC("A")="Select FORM to clone: " S DIC("W")=$P($T(DICW),";",3,999) DICW ;;N %G S %G=^(0) W:$X>35 ! W ?35,"#"_Y N Y S Y=$P(%G,U,5) W:Y]"" ?43,$$OUT^DIALOGU(Y,"FMTE","2D") S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y ;**CCO/NI NICE DATE OUTOUT D IX^DIC ; FORMQ Q Y ; GETBLKS ;Get all blocks on form ; ^TMP("DDSCLONE",$J,bk#)=Block name ; N B,P S P=0 F S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P D . S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2) . I B]"",'$D(^TMP("DDSCLONE",$J,B)) D .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U) . S B=0 . F S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B D .. Q:$D(^TMP("DDSCLONE",$J,B)) .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U) Q ; REPORT ;Print report N B W !!! I '$D(^TMP("DDSCLONE",$J)) S DDSQUIT=1 W "There are no blocks on this form." Q ; W " BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")" W !!," Internal" W !," Entry Number Block Name" W !," ------------ ----------" ; S B="" F S B=$O(^TMP("DDSCLONE",$J,B)) Q:B="" D . W !," "_B,?17,$P(^TMP("DDSCLONE",$J,B),U) ; K DIR S DIR(0)="E" W ! D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 W ! Q ; RENMSP ;Prompt for new namespace W !!,"The new form and blocks must be given unique names.",! ; K DIR S DIR(0)="Y",DIR("B")="YES" S DIR("A",1)="Give the new form and blocks the same names as the original," S DIR("A")="but a different namespace" S DIR("?",1)=" Answer 'YES' if the original form and blocks are namespaced, and you want" S DIR("?")=" the new forms and blocks to have a different namespace." D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q I 'Y K DDSONSP,DDSNNSP Q ; K DIR W !! S DIR(0)="FA^1:30" S DIR("A")="Original namespace: " S DIR("?")=" Enter the namespace of the original form and blocks" D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q S DDSONS=Y ; K DIR,X,Y S DIR(0)="FA^1:30" S DIR("A")=" New namespace: " S DIR("?")=" Enter the namespace of the new form and blocks" D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q S DDSNNS=Y K X,Y Q ; RENAME ;Prompt for new names N DDSBK,DDSBKDA D:'$D(IOST) HOME^%ZIS W @IOF W "Enter names for the new form and blocks." ; D RENFORM Q:DDSQUIT ; W ! S DDSBKDA=0 F S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA)) Q:'DDSBKDA!DDSQUIT D . S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA) . D RENBLK(.DDSBK) Q:DDSQUIT . S ^TMP("DDSCLONE",$J,DDSBKDA)=DDSBK . S ^TMP("DDSCLONE",$J,"B",$P(DDSBK,U,2))="" ; Q ; RENFORM ;Rename the form N DDSANS,DDSCOD F D Q:DDSANS]""!DDSQUIT . W !!,"Original form name: "_$P(DDSFORM,U,2) . W !," New form name: " . D EN^DIR0($S($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($P(DDSFORM,U,2),$G(DDSONS),$G(DDSNNS)),30,"","","",.DDSANS,.DDSCOD) . ; . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q . I DDSANS?1."?" W !!," Enter the name of the new form." S DDSANS="" . Q:DDSANS="" . S X=DDSANS X $P(^DD(.403,.01,0),U,5,999) . I '$D(X) S DDSANS="" W !!,$C(7)_" Invalid name." Q . I $D(^DIST(.403,"B",DDSANS)) D Q .. S DDSANS="" .. W !!,$C(7)_" Form with this name already exists." Q:DDSQUIT ; S $P(DDSFORM,U,3)=DDSANS Q ; RENBLK(DDSBK) ;Rename the blocks N DDSANS,DDSCOD F D Q:DDSANS]""!DDSQUIT . W !!,"Original block name: "_$P(DDSBK,U) . W !," New block name: " . D EN^DIR0($S($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($P(DDSBK,U),$G(DDSONS),$G(DDSNNS)),30,"","","",.DDSANS,.DDSCOD) . ; . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q . I DDSANS?1."?" W !!," Enter the name of the new form." S DDSANS="" . Q:DDSANS="" . S X=DDSANS X $P(^DD(.404,.01,0),U,5,999) . I '$D(X) S DDSANS="" W !!,$C(7)_" Invalid name." Q . D:$D(^DIST(.404,"B",DDSANS))!$D(^TMP("DDSCLONE",$J,"B",DDSANS)) .. S DDSANS="" .. W !!,$C(7)_" Block with this name already exists." Q:DDSQUIT ; S $P(DDSBK,U,2)=DDSANS Q ; NAME(NAME,ONS,NNS) ;Replace old namespace with new I $G(ONS)=""!($G(NNS)="") Q NAME I $P(NAME,ONS)]"" Q NAME Q NNS_$E(NAME,$L(ONS)+1,999) DDSCLONF^INT^1^60300,29509^0 DDSCLONF ;SFISC/MKO-CLONE A FORM ;15OCT2003 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. D ASKCONT Q:DDSQUIT D CREATBK Q:DDSQUIT D CREATFM Q:DDSQUIT D EDITFM D INDEXFM K DDSNFRM Q ; CREATBK ;Create blocks N DA,DIC W !!,"Creating new blocks ...",! S DDSBKDA=0 F S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA)) Q:'DDSBKDA!DDSQUIT D . S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA) . W !?2,$P(DDSBK,U,2) . K DIC,DD,DO . S DIC="^DIST(.404,",DIC(0)="QL",X=$P(DDSBK,U,2) . D FILE^DICN K DIC . I Y=-1 D Q .. W !,$C(7)_"Attempt to create block "_$P(DDSBK,U,2)_" failed." .. S DDSQUIT=1 . M ^DIST(.404,+Y)=^DIST(.404,DDSBKDA) . S $P(^DIST(.404,+Y,0),U)=$P(DDSBK,U,2) . W ?35,"#"_+Y . S $P(^TMP("DDSCLONE",$J,DDSBKDA),U,3)=+Y Q ; CREATFM ;Create form N DA,DIC,DDSI,DDSJ W !!,"Creating new form ..." W !?2,$P(DDSFORM,U,3) K DIC S DIC="^DIST(.403,",DIC(0)="QL",X=$P(DDSFORM,U,3) D FILE^DICN K DIC I Y=-1 D Q . W !,$C(7)_"Attempt to create form "_$P(DDSFORM,U,3)_" failed." . S DDSQUIT=1 M ^DIST(.403,+Y)=^DIST(.403,+DDSFORM) S $P(^DIST(.403,+Y,0),U,5)=DT ;GFT CREATE DATE IS TODAY! ; ;Kill page and block multiple indexes S DDSJ=" " F S DDSJ=$O(^DIST(.403,+Y,40,DDSJ)) Q:DDSJ="" D . K ^DIST(.403,+Y,40,DDSJ) S DDSI=0 F S DDSI=$O(^DIST(.403,+Y,40,DDSI)) Q:'DDSI D . S DDSJ=" " . F S DDSJ=$O(^DIST(.403,+Y,40,DDSI,40,DDSJ)) Q:DDSJ="" D .. K ^DIST(.403,+Y,40,DDSI,40,DDSJ) K @$$REF^DDS0(+Y) ; S $P(^DIST(.403,+Y,0),U)=$P(DDSFORM,U,3) W ?35,"#"_+Y S DDSNFRM=+Y Q ; EDITFM ;Edit blocks used on new form W !!,"Repointing to new blocks ..." N DDSBK,DDSNBK,DDSPG S DDSPG=0 F S DDSPG=$O(^DIST(.403,DDSNFRM,40,DDSPG)) Q:'DDSPG D . S DDSBK=$P(^DIST(.403,DDSNFRM,40,DDSPG,0),U,2) . I DDSBK]"" D .. N DIE,DA,DR .. S DIE="^DIST(.403,"_DDSNFRM_",40," .. S DA(1)=DDSNFRM,DA=DDSPG .. S DR="1////"_$P(^TMP("DDSCLONE",$J,DDSBK),U,3) .. D ^DIE . ; . N DA,DIK . S DIK="^DIST(.403,"_DDSNFRM_",40,"_DDSPG_",40," . S DA(2)=DDSNFRM,DA(1)=DDSPG . S DDSBK=0 . F S DDSBK=$O(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK)) Q:'DDSBK D .. Q:$D(^TMP("DDSCLONE",$J,DDSBK))[0 S DDSNBK=$P(^(DDSBK),U,3) .. M ^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK)=^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK) .. S $P(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK,0),U)=DDSNBK .. S DA=DDSBK .. D ^DIK Q ; INDEXFM ;Index new form W !,"Reindexing new form ..." N DIK,DA S DIK="^DIST(.403,",DA=DDSNFRM D IX1^DIK ; D EN^DDSZ(DDSNFRM) Q ; ASKCONT ;Final chance to abort K DIR S DIR(0)="Y" S DIR("A",1)="" S DIR("A")="Ready to clone form" S DIR("?")=" Enter 'Y' to clone form. Enter 'N' to exit." D ^DIR K DIR S:$D(DIRUT)!'Y DDSQUIT=1 Q DDSCOM^INT^1^61069,61055^0 DDSCOM ;SFISC/MLH-COMMAND UTILS ;12NOV2004 ;;22.0;VA FileMan;**999,1003,1004,1007**;Mar 30, 1999 COM ;Command line prompt D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG() N DDSCOM,DIR K DTOUT D SETUP(.DDSCOM,.X,.DIR) S DIR("?",1)=X S DIR("A")=$$EZBLD^DIALOG(8000),DIR("?",2)=" ",DIR("?")=$$EZBLD^DIALOG($S($G(DDSMOUSY):8000.101,1:8000.1)) ;'COMMAND' LINE & 'Enter a COMMAND' S DIR("??")="^D CHLP^DDSCOM" D:'$G(DDSKM) .K DDH,DDQ .F DDH=1:1:IOSL-DDSHBX-6 S DDH(DDH,"T")=" " ;ERASE EVERYTHING IN HELP AREA... .S DDH=DDH+1,DDH(DDH,"T")=DIR("?",1) .S DDH=DDH+1,DDH(DDH,"T")=DIR("?",2) .S DDH=DDH+1,DDH(DDH,"T")=DIR("?") .D SC^DDSU S DDM=1 K DDSKM S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^30^"_(IOSL-1)_"^0" D ^DIR K DUOUT,DIROUT,DIRUT TRANS S:X?1A.E (X,Y,Y(0))=$E("ECSNRPQ",$F(DIR("X"),$E($$UP^DILIBF(X)))-1) M DDSMOUSE(IOSL-5)=DDSCOM ;...DOWN TO 'Exit Save....' REMEMBER WHERE THESE SHOW FOR MOUSE D:X="C" . S:DDACT="N" Y="c" . S Y(0)="CLOSE" . S:DDACT'="N" (X,Y,Y(0))="" Q ; BOT ;from DIR0 & DIR02 I DDS?.N1"^MSCXQSCR" Q ;!!!!!! N X,XVIS,I,DIR,M,DIREPLIN S DY=IOSL-1,DX=0,$X=0 X IOXY W $P(DDGLCLR,DDGLDEL) ;Clear the bottom line S DIREPLIN=$P($$EZBLD^DIALOG(7002),U,$S($G(DIR0("REP")):2,1:1)) ;INSERT/REPLACE I '$G(DDSMOUSY) D .I DDO,'$G(DDM) W $$EZBLD^DIALOG(8000) ;**'COMMAND:' E I DDO D .D SETUP(.M,.X,.DIR) .K DDSMOUSE(DY) M DDSMOUSE(DY)=M S DX=0 W X S X=$$EZBLD^DIALOG($G(DDSMOUSY)/10+8074),DX=IOM-$L(DIREPLIN)-3-$L(X) I DX>$X D ;'F1-H FOR HELP' or 'HELP' if we have room . X IOXY . W $P(DDGLVID,DDGLDEL,10)_$P(DDGLVID,DDGLDEL,6)_X_$P(DDGLVID,DDGLDEL,10) .S DDSMOUSE(DY,DX,DX+$L(X)-1)="H^DIR0H" S DX=IOM-$L(DIREPLIN)-1 X IOXY W $S('$D(DDGLVAN):$P(DDGLVID,DDGLDEL,6),1:"")_DIREPLIN_$P(DDGLVID,DDGLDEL,10) ;INSERT/REPLACE S DDSMOUSE(DY,DX,DX+$L(DIREPLIN)-1)="RPM^DIR01" ;Make 'REPLACE' clickable Q ; ; ; SETUP(DDSM,X,DIR) ;DDSM, DIR, & X are return variables ;DDSM shows mouse positions ;DIR is array ;X is writeable string K DDSM,DIR("X") N DDSCH,DDSPP,XVIS F X=1:1:7 S DDSCH(X)=$$EZBLD^DIALOG(X/100+8000),$E(DIR("X"),X)=$C($A(DDSCH(X))),DDSCH(X,0)=$C($A(DDSCH(X))+32)_":"_$$UP^DILIBF(DDSCH(X)) S DDSPP=$$PP^DDS5(.X) I 'X S DDSPP="" ;Previous Page S X="" ;This will be the string of COMMANDs, with control sequences to highlight S XVIS="" ;just visible chars S DIR(0)="SO^" I DDSSC>1!$P(DDSSC(DDSSC),U,4) D ;POP-UP PAGE. IT ALSO DID THIS IF $G(DDSSEL) .D EXSANEXR(2,"CL"),EXSANEXR(5,"RF") .S DIR("B")=DDSCH(2) ;"Close" in Command Line E D .D EXSANEXR(1,"EX") D:$D(DDSFDO)[0 EXSANEXR(3,"SV") D:DDSNP]"" EXSANEXR(4,"NP^DDS2") D:DDSPP]"" EXSANEXR(6,"PP") D EXSANEXR(5,"RF") D EXSANEXR(7,"QT") S X=$E(X,1,$L(X)-4) Q EXSANEXR(N,JUMP) S DIR(0)=DIR(0)_DDSCH(N,0)_";",N=DDSCH(N),DDSM=$L(XVIS) S XVIS=XVIS_N_" " ;BUILD 'Exit Save ...' STRING I $G(DDSMOUSY) S X=X_$$HIGH^DDSU(N)_" " E S X=XVIS S DDSM(DDSM,DDSM+$L(N)-1)=JUMP ;Mouse positions for each character of displayed text Q ; ; ; CHLP ; K DDH,DDQ S DDH=0,DDS3CD=$P(DIR(0),U,2) F DDS3PC=1:1:$L(DDS3CD,";") D . S DDS3C=$C($A($P($P(DDS3CD,";",DDS3PC),":"))-32) . I "^E^C^S^N^R^P^Q^"[(U_DDS3C_U) D .. S DDH=DDH+1 .. S DDH(DDH,"T")=$E($P($T(@("H"_DDS3C)),";",3)_" ",1,11)_"- "_$$EZBLD^DIALOG($P($T(@("H"_DDS3C)),";",4)) ;**CC0/NI THE DIFFERENT COMMAND-LINE RESPONSES D:DDH>0 SC^DDSU K DDS3C,DDS3CD,DDS3PC Q HE ;;Exit;8000.11;**CCO/NI CHANGED THRU BOTTOM OF ROUTINE HC ;;Close;8000.12 HS ;;Save;8000.13 HN ;;Next Page;8000.14 HR ;;Refresh;8000.15 HP ;;Previous Page;8000.16 HQ ;;Quit;8000.17 DDSCOMP^INT^1^60300,29509^0 DDSCOMP ;SFISC/MKO-EVALUATE COMPUTED EXPRESSIONS ;8:55 AM 12 Feb 1999 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; PARSE(DDP,EXP,BK,NEXP,AR,FDL) ;Parse the computed expression EXP ;Returns: ; NEXP = EXP with {expr} replaced with DDSE(n) ; AR = array when executed sets DDSE(n) ; FDL = list of fields referenced N I,J,N,ST ; S NEXP="",(N,AR)=0,ST=1 S I=0 F D Q:'I!$G(DIERR) . S I=$$FIND^DDSLIB(EXP,"{",I) Q:'I . S N=N+1 . S NEXP=NEXP_$E(EXP,ST,I-2)_"DDSE("_N_")" . S ST=$$FIND^DDSLIB(EXP,"}",I) . D EVAL(DDP,$E(EXP,I,ST-2),BK,N,.AR,.FDL) Q:$G(DIERR) . S I=ST Q:$G(DIERR) S NEXP=$S(EXP?1"=".E:"S Y",1:"")_NEXP_$E(EXP,ST,999) ; S AR=N S:$G(FDL)]"" FDL=$E(FDL,1,$L(FDL)-1) Q ; EVAL(DDP,EXP,BK,N,AR,FDL) ;Evaluate field expression ;In: ; EXP = computed expr ; N = expr number -- index into DDSE() ;Out: ; AR = array of code that sets DDSE(n) ; FDL = list of fields used in expr ; N CD D:EXP?1"FO(".E FO^DDSPTR(DDP,EXP,"","",BK,.CD,.FDL,1) D:EXP'?1"FO(".E DD^DDSPTR(DDP,EXP,"",.CD,.FDL,1) Q:$G(DIERR) ; I CD=1 S AR(N)="N X "_CD(1)_",DDSE("_N_")=X" E D . F CD=1:1:CD S AR(N,CD)=CD(CD) . S AR(N,CD)=AR(N,CD)_",DDSE("_N_")=X" . S AR(N)="N DDSI,X S DDSE("_N_")="""" F DDSI=1:1:"_CD_" Q:DDSI>1&($G(X)'>0)!'$D(*DDSREFC*,DDSI)) X ^(DDSI)" Q ; RPCF(DDSPG) ;Repaint computed fields ;Called from ^DDS01 and ^DDSVALF when value used in ;computed expression changes N DDSCBK,DDSCDDO ; S DDSCBK="" F S DDSCBK=$O(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG,DDSCBK)) Q:DDSCBK="" D . I $P($G(@DDSREFS@(DDSPG,DDSCBK)),U,7)>1 D DB^DDSR(DDSPG,DDSCBK) Q . N DA,DDSDA . D GETDA(DDSPG,DDSCBK,.DA) . S DDSDA=$$DDSDA(.DA) . S DDSCDDO="" F S DDSCDDO=$O(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG,DDSCBK,DDSCDDO)) Q:DDSCDDO="" D RPCF1 ; Q ; RPCF1 ; N DDSC,DDSE,DDSLEN,DDSX S DDSC=$G(@DDSREFS@(DDSPG,DDSCBK,DDSCDDO,"D")) Q:DDSC="" S DDSX=$$VAL(DDSCDDO,DDSCBK,DDSDA) ; S DY=+DDSC,DX=$P(DDSC,U,2),DDSLEN=$P(DDSC,U,3) I $P(DDSC,U,10) S DDSX=$J("",DDSLEN-$L(DDSX))_$E(DDSX,1,DDSLEN) E S DDSX=$E(DDSX,1,DDSLEN)_$J("",DDSLEN-$L(DDSX)) X IOXY W $P(DDGLVID,DDGLDEL)_DDSX_$P(DDGLVID,DDGLDEL,10) ; N DDP,DDSFLD S DDP=0,DDSFLD=DDSCDDO_","_DDSBK D:$D(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG)) RPCF(DDSPG) ; Q ; GETDA(P,B,DA) ;Get DA array of block N I K DA S DA=$G(@DDSREFT@(P,B)) Q:DA="" Q:'$G(^(B,DA)) F I=2:1:$L(DA,",")-1 S DA(I-1)=$P(DA,",",I) S DA=+DA Q ; VAL(DDSDDO,DDSBK,DDSDA) ;Return value of computed field N DDSE,DDSX,Y I $D(DDSDA) N DA D DA(DDSDA,.DA) S DDSX=0 F S DDSX=$O(@DDSREFS@("COMPE",DDSBK,DDSDDO,DDSX)) Q:DDSX="" X ^(DDSX) K Y X $G(@DDSREFS@("COMPE",DDSBK,DDSDDO)) Q $G(Y) ; DA(DDSDA,DA) ;Return DA array based on DDSDA N I S DA=$P(DDSDA,",") F I=2:1:$L(DDSDA,",") S DA(I-1)=$P(DDSDA,",",I) Q ; DDSDA(DA) ;Return DDSDA based on DA array N DDSDA,I I $G(DA)="" S DDSDA="0," E D . S DDSDA=DA_"," . F I=1:1 Q:$G(DA(I))="" S DDSDA=DDSDA_DA(I)_"," Q DDSDA DDSDBLK^INT^1^60300,29509^0 DDSDBLK ;SFISC/MKO-DELETE UNUSED BLOCKS ;01:25 PM 11 Oct 1999 ;;22.0;VA FileMan;**999**;Mar 30, 1999 ; N %,D,DIAC,DIC,DIFILE,DIOVRD,X,Y D INIT S DDSFILE=$$FILE G:DDSFILE=-1 QUIT D SUB(+DDSFILE,DDSSUB),FINDB(DDSSUB,DDSBLK),PROC,QUIT Q ; ALL ;Purge all unused blocks regardless of file N %,DIC,DIOVRD,X,Y K DDSFILE D INIT,FINDALL(DDSBLK),PROC,QUIT Q ; PROC ;Delete blocks in @DDSBLK I '$D(@DDSBLK) D Q . W !!!,"There are no unused blocks associated with this file." ; D REPORT D ASKDEL Q:DDSQUIT D ASKCONT Q:DDSQUIT ; ;Delete blocks D:$G(DDSDEL) DELNPR D:'$G(DDSDEL) DELPR W !!,"DONE!" Q ; INIT ;Initialize variables S (DDSDEL,DDSQUIT)=0,DIOVRD=1 S DDSBLK=$NA(^TMP("DDSDBLK",$J,"BLK")) S DDSSUB=$NA(^TMP("DDSDBLK",$J,"SUB")) K @DDSBLK,@DDSSUB Q ; QUIT ;Cleanup K @DDSBLK,@DDSSUB K DDSBLK,DDSDEL,DDSFILE,DDSQUIT,DDSSUB K DDH,DIRUT,DIROUT,DTOUT,DUOUT Q ; FINDB(DDSSUB,DDSBLK) ;Find blocks associated with a specific file N B,B0,N S B=0 F S B=$O(^DIST(.404,B)) Q:'B S B0=$G(^(B,0)) D . S N=$P(B0,U,2) . I N,$D(@DDSSUB@(N)),'$D(^DIST(.403,"AB",B)),'$D(^DIST(.403,"AC",B)) S @DDSBLK@(B)=$P(B0,U) Q ; FINDALL(DDSBLK) ;Find all unused blocks N B,B0 S B=0 F S B=$O(^DIST(.404,B)) Q:'B S B0=$G(^(B,0)) D . I '$D(^DIST(.403,"AB",B)),'$D(^DIST(.403,"AC",B)) D .. S @DDSBLK@(B)=$P(B0,U) Q ; FILE() ;Prompt for form ;Select file N DIC,Y EGP S DDS1=8108.1 D W^DICRW K DDS1 G:Y<0 FILEQ ;**CCO/NI 'PURGE UNUSED BLOCKS' S:'$D(@(DIC_"0)")) Y=-1 FILEQ Q Y ; DELPR ;Delete blocks with prompting N DDSB W ! K DIK,DIR,DIRUT S DIR(0)="YA",DIR("B")="NO" S DIR("?")=" Enter 'Y' to delete, 'N' to keep." S DIK="^DIST(.404," ; S DDSB="" F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""!DDSQUIT D . S DIR("A")=$P(@DDSBLK@(DDSB),U)_$J("",30-$L($P(@DDSBLK@(DDSB),U)))_"Delete (Y/N)? " . D ^DIR S:$D(DIRUT) DDSQUIT=1 Q:'Y . S DA=DDSB D ^DIK K DA,DIR,DIK,DIRUT,DTOUT,DUOUT,DIROUT Q ; DELNPR ;Delete blocks without prompting N DDSB W ! K DIK S DIK="^DIST(.404," S DDSB="" F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB="" D . W !,"Deleting block "_$P(@DDSBLK@(DDSB),U)_" (IEN #"_DDSB_") ..." . S DA=DDSB D ^DIK K DIK,DA Q ; ASKDEL ;Ask if user wants to delete all unused blocks w/o confirmation W ! S DIR(0)="YA",DIR("B")="NO" S DIR("A",1)="" S DIR("A")="Delete all unused blocks without prompting (Y/N)? " S DIR("?",1)=" Enter 'Y' to delete unused blocks from the BLOCK file" S DIR("?",2)=" without confirmation." S DIR("?",3)="" S DIR("?")=" Enter 'N' to confirm each delete." D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q S DDSDEL=Y Q ; ASKCONT ;Final chance to abort K DIR S DIR(0)="YA",DIR("B")="NO" S DIR("A",1)="" S DIR("A")="Continue (Y/N)? " S DIR("?")=" Enter 'Y' to delete form. Enter 'N' to exit." D ^DIR K DIR S:$D(DIRUT)!'Y DDSQUIT=1 Q ; REPORT ;Print report N B W !!! W " UNUSED BLOCKS" W:$D(DDSFILE) " ASSOCIATED WITH FILE "_$P(DDSFILE,U,2)_" (#"_$P(DDSFILE,U)_")" W !!," Internal" W !," Entry Number Block Name" W !," ------------ ----------" ; S B="" F S B=$O(@DDSBLK@(B)) Q:B="" W !," "_B,?17,@DDSBLK@(B) Q ; SUB(FN,OUT) ; ;Set OUT array for file number FN and all its subfiles N SUB I $D(^DD(FN)) S @OUT@(FN)="" S SUB="" F S SUB=$O(^DD(FN,"SB",SUB)) Q:SUB="" D SUB(SUB,OUT) Q DDSDEL^INT^1^60300,29509^0 DDSDEL ;SFISC/MKO-DELETE FORMS FOR A FILE ;24JUL2003 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; FORM(DDSFILE,DDSECHO) ; ;Delete all forms/blocks associated with file DDSFILE N DDSREF,DDSBLK,DDSBNAM,DDSFRM,DDSOFRM,DDSLN,DDSPDD,DDSPG N %,DIK,DIOVRD,DA,D0,X,Y I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU S DIOVRD=1 D SETUP,GETFORMS(DDSFILE,DDSREF) ; ;Delete forms W:DDSECHO !?3,"Deleting the FORMS..." S DDSFRM="",DIK="^DIST(.403," F S DDSFRM=$O(@DDSREF@("FRM",DDSFRM)) Q:'DDSFRM S DA=DDSFRM D ^DIK K DIK,DA ; ;Delete blocks W:DDSECHO !?3,"Deleting the BLOCKS..." S DDSBLK="",DIK="^DIST(.404," F S DDSBLK=$O(@DDSREF@("BLK",DDSBLK)) Q:'DDSBLK D . S DDSLN=@DDSREF@("BLK",DDSBLK) . S DDSBNAM=$P(DDSLN,U),DDSOFRM=$P(DDSLN,U,2),DDSPDD=$P(DDSLN,U,3) . ; . I DDSOFRM,DDSPDD D .. I DDSECHO D ... W !!?3,$C(7)_"*** Warning ***" ... W !!?3,"Block "_DDSBNAM_" (#"_DDSBLK_")" ... W !?3,"was deleted from the Block file." ... W !!?3,"I'm deleting pointers to that block from" .. S DDSFRM="" .. F S DDSFRM=$O(@DDSREF@("BLK",DDSBLK,DDSFRM)) Q:'DDSFRM D ... W:DDSECHO !?6,"Form "_$P(^DIST(.403,DDSFRM,0),U)_" (#"_DDSFRM_") ..." ... D DELBLK(DDSBLK,DDSFRM) .. W:DDSECHO !!?3,"The above form(s) need to be redesigned.",! . ; . E I 'DDSOFRM D .. S DA=DDSBLK D ^DIK ; QUIT ;Cleanup and quit K @DDSREF Q ; SETUP ;Setup local variables S:$D(DDSECHO)[0 DDSECHO=0 S DDSREF="^TMP(""DDSDEL"","""_$J_""")" ;IF $J IS NOT NUMERIC K @DDSREF Q ; GETFORMS(FILE,REF) ; ;Get all forms and blocks associated with file number FILE ;and all subfiles associated with FILE ;Put results in ; @REF@("DD",file#) = null ; ("FRM",form#) = form name ; ("BLK",block#) = block name^used on forms not being ; deleted^dd of block is being deleted ; ("BLK",block#,form#) = null for all blocks that are found ; on a form not being deleted ; N B,F,P,FNAM ;Get DDs of file and subfiles D DD(FILE,REF) ; ;Get all forms associated with file S FNAM="" F S FNAM=$O(^DIST(.403,"F"_FILE,FNAM)) Q:FNAM="" D . S F="" F S F=$O(^DIST(.403,"F"_FILE,FNAM,F)) Q:F="" D .. Q:$D(^DIST(.403,F,0))[0 .. S @REF@("FRM",F)=$P(^DIST(.403,F,0),U) ; ;Get all blocks associated with each form S F="" F S F=$O(@REF@("FRM",F)) Q:F="" D . S P=0 F S P=$O(^DIST(.403,F,40,P)) Q:'P D .. S B=$P($G(^DIST(.403,F,40,P,0)),U,2) .. I B D SETBLK(B,REF) .. S B=0 F S B=$O(^DIST(.403,F,40,P,40,B)) Q:'B D SETBLK(B,REF) Q ; SETBLK(B,REF) ; ;Put block info into @REF N B0 S B0=$G(^DIST(.404,B,0)) Q:B0?."^" S @REF@("BLK",B)=$P(B0,U)_U_$$OTHER(B,REF)_U_($D(@REF@("DD",+$P(B0,U,2)))#2) Q ; DELBLK(DDSBLK,DDSFRM) ; ;Delete block DDSBLK from form DDSFRM N DIK,DA,D0 S DDSPG=0 F S DDSPG=$O(^DIST(.403,DDSFRM,40,DDSPG)) Q:'DDSPG D . I $D(^DIST(.403,DDSFRM,40,DDSPG,40,"B",DDSBLK)) D .. S DIK="^DIST(.403,"_DDSFRM_",40,"_DDSPG_",40," .. S DA(2)=DDSFRM,DA(1)=DDSPG,DA=DDSBLK .. D ^DIK Q ; DD(F,REF,K) ; ;Put file # and all its subfile #s into array @REF@("DD") ;Kill REF first if $G(K)="" N SB K:$G(K)="" @REF@("DD") S @REF@("DD",F)="" S SB="" F S SB=$O(^DD(F,"SB",SB)) Q:SB="" D DD(SB,REF,1) Q ; OTHER(B,REF) ; ;Is block B found on forms other than what's in @REF@("FRM",F)="" ;If so, put form numbers in @REF@("BLK",B,F) N F,O,C S O=0,F="" F C="AB","AC" F S F=$O(^DIST(.403,C,B,F)) Q:F="" D . I $D(@REF@("FRM",F))[0 S O=1,@REF@("BLK",B,F)="" Q O DDSDFRM^INT^1^60300,29509^0 DDSDFRM ;SFISC/MKO-DELETE A FORM ;11:22 AM 4 Dec 1999 ;;22.0;VA FileMan;**999**;Mar 30, 1999 ; N %,DIC,DIOVRD,X,Y D INIT S (DDSDEL,DDSQUIT)=0 ; S DDSFORM=$$FORM G:DDSFORM=-1 QUIT ; D GETBLKS D REPORT I $D(@DDSBLK) D ASKDEL G:DDSQUIT QUIT D ASKCONT G:DDSQUIT QUIT ; ;Delete form W !!,"Deleting form "_$P(DDSFORM,U,2)_" (IEN #"_+DDSFORM_") ..." S DIK="^DIST(.403,",DA=+DDSFORM D ^DIK K DIK,DA ; ;Delete blocks I DDSDEL D:'$G(DDSDEL(1)) DELPR D:$G(DDSDEL(1)) DELNPR W !!,"DONE!" D QUIT Q ; EN(DDSFORM) ;Delete form number DDSFORM N %,DA,DDSB,DDSBLK,DIC,DIK,DIOVRD,X,Y I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU D INIT D GETBLKS ; ;Delete form S DIK="^DIST(.403,",DA=+DDSFORM D ^DIK K DIK,DA ; ;Delete blocks S DIK="^DIST(.404," S DDSB="" F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB="" D . Q:$P(@DDSBLK@(DDSB),U,2) . S DA=DDSB D ^DIK ; K @DDSBLK Q ; INIT ;Setup S DIOVRD=1 S DDSBLK=$NA(^TMP("DDSDFRM",$J,"BLK")) K @DDSBLK Q ; QUIT ;Cleanup K @DDSBLK K DDSBLK,DDSDEL,DDSFILE,DDSFORM,DDSQUIT K DDH,DIRUT,DIROUT,DTOUT,DUOUT Q ; FORM() ;Prompt for form ;Select file N D,DIC EGP S DDS1=8108.2 D W^DICRW K DDS1 G:Y<0 FORMQ ;**CCO/NI 'DELETE FORM' I '$D(@(DIC_"0)")) S Y=-1 G FORMQ S DDSFILE=Y ; ;Select form W ! K DIC S DIC="^DIST(.403,",DIC(0)="QEAM" S DIC(0)="QEA",D="F"_+DDSFILE S DIC("S")="I $P(^(0),U,8)=+DDSFILE" S DIC("A")="Select FORM to delete: " S DIC("W")=$P($T(DICW),";",3,999) DICW ;;N %G S %G=^(0) W:$X>35 ! W ?35,"#"_Y N Y S Y=$P(%G,U,5) W:Y]"" ?43,$$OUT^DIALOGU(Y,"FMTE","2D") S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y ;**CCO/NI NICE DATE FORMAT D IX^DIC ; FORMQ Q Y ; GETBLKS ;Get all blocks on form ; @DDSBLK@(bk#)=Block name^flag (1=used on other forms) ; N P,B S P=0 F S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P D . S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2) . I B]"",'$D(@DDSBLK@(B)) D .. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM) . S B=0 . F S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B D:'$D(@DDSBLK@(B)) .. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM) Q ; DELPR ;Delete blocks with prompting N DDSB W ! K DIK,DIR,DIRUT S DIR(0)="YA",DIR("B")="NO" S DIR("?")=" Enter 'Y' to delete, 'N' to keep." S DIK="^DIST(.404," ; S DDSB="" F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""!DDSQUIT D . Q:$P(@DDSBLK@(DDSB),U,2) . S DIR("A")=$P(@DDSBLK@(DDSB),U)_$J("",30-$L($P(@DDSBLK@(DDSB),U)))_"Delete (Y/N)? " . D ^DIR S:$D(DIRUT) DDSQUIT=1 Q:'Y . S DA=DDSB D ^DIK K DA,DIR,DIK,DIRUT,DTOUT,DUOUT,DIROUT Q ; DELNPR ;Delete blocks without prompting N DDSB W ! K DIK S DIK="^DIST(.404," S DDSB="" F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB="" D . Q:$P(@DDSBLK@(DDSB),U,2) . W !,"Deleting block "_$P(@DDSBLK@(DDSB),U)_" (IEN #"_DDSB_") ..." . S DA=DDSB D ^DIK K DIK,DA Q ; ASKDEL ;Ask if user wants to delete all the blocks on this form K DIR W ! S DIR(0)="YA",DIR("B")="YES" S DIR("A",1)="" S DIR("A",2)="Delete all deletable blocks used on form "_$P(DDSFORM,U,2) S DIR("A")="from the BLOCK file (Y/N)? " S DIR("?",1)=" Enter 'Y' to delete blocks used on form" S DIR("?",2)=" "_$P(DDSFORM,U,2)_" from the BLOCK file." S DIR("?",3)=" (Only blocks not used on other forms can be deleted.)" S DIR("?",4)="" S DIR("?")=" Enter 'N' to delete the form but not the blocks." D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q S DDSDEL=Y Q:'DDSDEL ; ;Ask if user wants to delete without prompting W ! S DIR(0)="YA",DIR("B")="NO" S DIR("A",1)="" S DIR("A")="Delete blocks without prompting (Y/N)? " S DIR("?",1)=" Enter 'Y' to delete blocks from the BLOCK file" S DIR("?",2)=" without confirmation." S DIR("?",3)="" S DIR("?")=" Enter 'N' to confirm each delete." D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q S DDSDEL(1)=Y Q ; ASKCONT ;Final chance to abort K DIR S DIR(0)="YA",DIR("B")="NO" S DIR("A",1)="" S DIR("A")="Continue (Y/N)? " S DIR("?")=" Enter 'Y' to delete form. Enter 'N' to exit." D ^DIR K DIR S:$D(DIRUT)!'Y DDSQUIT=1 Q ; REPORT ;Print report N B W !!! I '$D(@DDSBLK) W "There are no blocks on this form." Q W " BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")" W !!," Internal",?50,"Used on" W !," Entry Number Block Name",?50,"Other Forms? Deletable?" W !," ------------ ----------",?50,"------------ ----------" ; S B="" F S B=$O(@DDSBLK@(B)) Q:B="" D . W !," "_B,?17,$P(@DDSBLK@(B),U),?54 . W $S($P(@DDSBLK@(B),U,2):"YES",1:"NO") . W ?68,$S($P(@DDSBLK@(B),U,2):"NO",1:"YES") Q ; COMMON(B,F) ;Is block B found on forms other than F N C,F1 S C=0,F1="" F S F1=$O(^DIST(.403,"AB",B,F1)) Q:F1="" I F1'=F S C=1 Q I 'C S F1="" F S F1=$O(^DIST(.403,"AC",B,F1)) Q:F1="" I F1'=F S C=1 Q Q C DDSFO^INT^1^60300,29509^0 DDSFO ;SFISC/MKO-FORM ONLY FIELDS ;1:52 PM 19 Jun 1998 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. DIR ;Setup input variables to DIR N I,J S DIR(0)=$P(DDSO(20),U)_$P(DDSO(20),U,2,3) S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999) S:$P(DIR(0),U)'["O" $P(DIR(0),U)=$P(DIR(0),U)_"O" I $P(DIR(0),U)["P",$P($P(DIR(0),U,2),":",2)'["Z" D . S I=$P(DIR(0),U,2) Q:$P(I,":",2)["Z" . S $P(I,":",2)=$P(I,":",2)_"Z" . S $P(DIR(0),U,2)=I S:$G(^DIST(.404,DDSBK,40,DDO,22))'?."^" $P(DIR(0),U,3)=^(22) I $D(^DIST(.404,DDSBK,40,DDO,21)) D . S (I,J)=0 . F S I=$O(^DIST(.404,DDSBK,40,DDO,21,I)) Q:I="" I $D(^(I,0))#2 S J=J+1,DIR("?",J)=^(0) . I J>0 S DIR("?")=DIR("?",J) K DIR("?",J) X:$G(^DIST(.404,DDSBK,40,DDO,24))'?."^" ^(24) Q DDSIT^INT^1^60300,29509^0 DDSIT ;SFISC/MKO-INPUT TRANSFORMS ;09:07 AM 24 Oct 1994 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; PFIELD ;Input transform for the PARENT FIELD field of the PAGE multiple ;of the Form file. N DDSMF S DDSMF=$$GETFLD^DDSLIB($P(X,","),$P(X,",",2),$P(X,",",3),DA(1)) G QUIT ; PLINK ;Input transform for POINTER LINK field of the BLOCK multiple of ;the PAGE MULTIPLE of the Form file. N DDP,DDSCD,DDSERR,DDS ; S DDP=$P($G(^DIST(.403,DA(2),0)),U,8) I 'DDP D G QUIT . N P . S P(1)="PRIMARY FILE",P(2)="FORM" . D BLD^DIALOG(3011,.P) ; S DDS=DA(2)_U_$P(^DIST(.403,DA(2),0),U) D:X?1"FO(".E FO^DDSPTR(DDP,X,DA(2),DA(1)) D:X'?1"FO(".E DD^DDSPTR(DDP,X,DA) G QUIT ; CEXPR ;Input transform for COMPUTED EXPRESSION field N DDP,DDSX,DDSNEXP S DDP=$P($G(^DIST(.404,DA(1),0)),U,2) D PARSE^DDSCOMP(DDP,X,DA(1),.DDSNEXP) G:$G(DIERR) QUIT ; S DDSX=X,X=DDSNEXP D ^DIM S:$D(X) X=DDSX Q ; QUIT ;Check error and quit I $G(DIERR) N DDSERR D MSG^DIALOG("AB",.DDSERR),EN^DDIOL(.DDSERR) K X Q DDSLIB^INT^1^60300,29509^0 DDSLIB ;SFISC/MKO-LIBRARY FUNCTIONS ;11:55 AM 14 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 FIND(E,C,S) ;Find in expression E, starting from pos S, the char pos ;after the next occurrence of char C, ignoring those within quoted ;strings. N I,J,P S:'$D(S) S=1 F D Q:$D(P) . S I=$F(E,C,S),J=$F(E,"""",S) . I 'I S P=I Q . I J,J1 S DDSSN=DDSSN-1 I DDSCL>1 D . S DDSCL=DDSCL-1 D MDA E D . S DDSSTL=DDSSTL-1 . D MDA,DB^DDSR(DDSPG,DDSBK) Q ; MDN ;Move down a line Q:'DA S DDSSN=DDSSN+1 I DDSCL0,'$G(@DDSREFT@(DDSPG,DDSBK,"COMP MUL")) D ;If this is top level of a pointing file, stuff the pointer back to where we came from .. N DR,X,Y .. S Y=$P(DDSREP,U,9) Q:Y="" .. S DR=$O(^DD(DDSFN,0,"IX",Y,DDSFN,""))_"////"_+DDSREP Q:'DR .. D ^DIE . ; . D ADD(DDSDA,DDSPDA,DDSSN) . S DDSFN="F"_DDSFN . D DMULT1^DDSR(DDSPG,DDSBK,DDSFN,DDSDA,DDSLN,DDSSN) . S DDSCHKQ=2 E D . S DDSCHKQ=1 . D POSDA(DDSDA) ;They have entered something already on the muliple display. Jump to it. ; S Y=$P(Y,U) S:X="" Y="" Q ; END ; S DDACT="N" Q:'DA D POSSN(999999999999) Q ; PGDN ;Page down S DDACT="N" I 'DA D . I DDSNP]"" S DDSPG=DDSNP,DDACT="NP" E D POSSN($P(DDSREP,U,2)+$P(DDSREP,U,5)) Q ; PGUP ;Page up S DDACT="N" I $P(DDSREP,U,4)=1 D . S DDSPG=$$PP^DDS5(.Y) . S:Y=1 DDACT="NP" E D POSSN($P(DDSREP,U,2)-$P(DDSREP,U,5)) Q ; POSSN(DDSSN,DDSPAINT) ;Make line with given DDSSN current N DDSLSN,DDSPDA,DDSSTL S DDSPDA=$P(DDSREP,U) S DDSSTL=$P(DDSREP,U,2) ; S DDSLSN=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA," "),-1)+1 S DDSSN=$$MIN(DDSLSN,DDSSN) S:DDSSN<1 DDSSN=1 ; S DDSDA=$G(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN),"0,"_$P(DDSDA,",",2,999)) S DA=+DDSDA,@("D"_DDSDL)=DA ; S:'DA DDO=$P(DDSREP,U,8) I DDSSN'Y:X,1:Y) DDSM1^INT^1^60300,29509^0 DDSM1 ;SFISC/MKO-MULTILINE, LOAD AND DELETE ;26SEP2003 ;;22.0;VA FileMan;**8,1003**;Mar 30, 1999 ; LOAD(DDSIEN) ;Load subentries MLOAD ;Entry point from MLOAD^DDSUTL ;@DDSIEN is an array of record numbers ; Q:$D(DDSIEN)[0 Q:$D(@DDSIEN)<9 ; N DDSI,DDSPDA,DDSRN,DDSSN S DDSPDA=$P(DDSREP,U) S DDSSN=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA," "),-1) ; ;Add records to internal ^TMP array ;Load data for each record S DDSI="" F S DDSI=$O(@DDSIEN@(DDSI)) Q:DDSI="" D . S DDSRN=@DDSIEN@(DDSI) Q:'DDSRN . S DA=+DDSRN,$P(DDSDA,",")=DA,@("D"_DDSDL)=DA . I $D(@DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA))[0 D .. S DDSSN=DDSSN+1 .. S @DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA)=DDSSN .. S @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)=DDSDA .. S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=DDSDA_DIE . D ^DDS11(DDSBK) . S DDSCHG=1 ; ;Position the cursor on blank (Select) line ;Repaint all lines in the repeating block D POSSN^DDSM(999999999999) D DMULTN^DDSR(DDSPG,DDSBK,DDSPDA,$P(DDSREP,U,5),1) ; ;Update DIR0 DIR0 S DIR0=$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,1,3) S:$P($G(DDSREP),U,3)>1 $P(DIR0,U)=$P(DIR0,U)+($P(DDSREP,U,3)-1*$$HITE^DDSR(DDSBK)) ;DJW/GFT Q ; DEL(DDSIEN) ;Delete subentries MDEL ;Entry point from MDEL^DDSUTL ;In: ; If DDSIEN contains a record number, delete that one (G MDELONE) ; If DDSIEN contains a closed root, @DDSIEN is an array ; of record numbers to delete ; DIE = global root ; DDSDA = current IENS ; Q:$D(DDSIEN)[0 G:+$P(DDSIEN,"E") MDELONE Q:$D(@DDSIEN)<9 ; N DDSI,DDSPDA,DDSRN,DDSSN S DDSPDA=$P(DDSREP,U) ; ;Loop through passed array and delete subentries S DDSI="" F S DDSI=$O(@DDSIEN@(DDSI)) Q:DDSI="" D . ;S DDSRN=@DDSIEN@(DDSI) Q:'DDSRN . ;S DDSIENS=DDSDA,$P(DDSIENS,",")=+DDSRN . ;D K^DDS6(DDSIENS,DIE) . ;Q . ; . S DDSRN=@DDSIEN@(DDSI) Q:'DDSRN . S DA=+DDSRN,$P(DDSDA,",")=DA . S DDSSN=$G(@DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA)) Q:'DDSSN . K @DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA) . K @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN) . K @DDSREFT@("F"_DDP,DDSDA) . K @DDSREFT@("F0",DDSDA) ; ;Close up gaps in ^TMP array S (DDSI,DDSSN)=0 F S DDSI=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSI)) Q:'DDSI D . S DDSSN=DDSSN+1 Q:DDSI=DDSSN . S DDSRN=@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSI) . S @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)=DDSRN . S @DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSRN)=DDSSN ; F S DDSSN=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)) Q:'DDSSN D . K @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN) ; ;Position cursor on "Select" line ;Repaint all lines in repeating block D POSSN^DDSM(999999999999,1) ; ;Update DIR0 DIR01 D DIR0 Q ; MDELONE ;Delete one subentry in the current repeating block ;In: DDSIEN = IENS of record to be deleted ; DDSREP = data for repeating blocks ; DDSDA = current IENS ; DIE = current global root ; N DDSPDA,DDSRN,DDSSN ; ;Get parent IENS S DDSPDA=$P(DDSREP,U) ; ;Kill all data pertaining to current (sub)record D K^DDS6(DDSIEN,DIE) ; ;Repaint lines and reposition cursor I DDSDA=DDSIEN D . D DMULTN^DDSR(DDSPG,DDSBK,DDSPDA,$P(DDSREP,U,5),$P(DDSREP,U,3)) . S DDSSN=$P(DDSREP,U,4) . I $D(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN))[0 D .. S DDSSN=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN),-1) . D POSSN^DDSM(DDSSN) ; E D POSSN^DDSM(999999999999,1) ; DIR02 D DIR0 Q DDSMSG^INT^1^60300,29509^0 DDSMSG ;SFISC/MKO-PRINT MESSAGES ;3:14 PM 9 Feb 2001 ;;22.0;VA FileMan;**75**;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; ERR ;Print "DIERR" messages in help box N DDSE,DDSL,DDSLMT,DDSN K DDH,DDQ S DDSLMT=$G(DDC,15),DDSE=0 ; W $C(7) S DDSN=0 F S DDSN=$O(^TMP("DIERR",$J,DDSN)) Q:'DDSN!DDSE D . S DDSL=0 . F S DDSL=$O(^TMP("DIERR",$J,DDSN,"TEXT",DDSL)) Q:'DDSL!DDSE D .. D LD($G(^TMP("DIERR",$J,DDSN,"TEXT",DDSL)),"!") .. I DDH'DDSHBX SETDDH S DDSLMT=$G(DDC,15),(DDSE,DDSL)=0 ; F S DDSL=$O(@DDSG@(DDSL)) Q:'DDSL!DDSE D . S DDST=$G(@DDSG@(DDSL)) . I DDST="$$EOP" S DDH=$G(DDH)+1,DDH(DDH,"E")="" . E D LD(DDST,$G(@DDSG@(DDSL,"F"),"!")) . S DDSNXTF=$G(@DDSG@(DDSL+1,"F"),"!") . I DDH'DDSHBX SETDDH S DDSLMT=$G(DDC,15),(DDSE,DDSL)=0 ; F S DDSL=$O(@DDSR@(DDSL)) Q:'DDSL!DDSE D . D LD($G(@DDSR@(DDSL,0)),$G(@DDSR@(DDSL,"F"),"!")) . S DDSNXTF=$G(@DDSR@(DDSL+1,"F"),"!") . I DDH'DDSHBX SETDDH ; I $D(DDSMSG)=1 D . D LD(DDSMSG,$S($G(DDSFMT)]"":DDSFMT,1:"!")) ; E S DDSL=0 F S DDSL=$O(DDSMSG(DDSL)) Q:'DDSL D . D LD($G(DDSMSG(DDSL)),$G(DDSMSG(DDSL,"F"),"!")) Q:'$G(DDH) ; I $G(DDH) D . S:$G(DDH(1,"T"))?1.C DDH(1,"T")="" . S:$G(DDSFLG)[1 DDH(1,"T")=$C(7)_$G(DDH(1,"T")) . D SC^DDSU S:'$D(DDSID) DDSKM=1 Q ; SETDDH ;Setup DDH and DDQ for identifiers and executable help ;that called EN^DDIOL S:$X>IOM $X=IOM S DDH=1 S DDH(1,"T")=$TR($J("",$X)," ",$C(0)) S DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)-1_U_$X Q ; LD(S,F) ;Load string S with format F into DDH array N A,C,J,L S DDH=+$G(DDH) F J=1:1:$L(F,"!")-1 S DDH=DDH+1,DDH(DDH,"T")="" S:'DDH DDH=1 S:F["?" @("C="_$P(F,"?",2)) S L=$G(DDH(DDH,"T")) S S=L_$J("",$G(C)-$L(L))_S ; D WRAP(S,.A,IOM-1) S DDH=DDH-1 F A=1:1:A S DDH=$G(DDH)+1,DDH(DDH,"T")=A(A) Q ; WRAP(L,A,M) ;Wrap line at word boundaries ; L = Line of text ; M = Margin width ;Return: ; A = Number of lines ; A(n) = Array of text ; S:'$G(M) M=$S($G(IOM):IOM-5,1:75) N I,N S N=0 F I=$L(L," "):-1:1 D Q:L="" . I I=1 S N=N+1,A(N)=$E(L,1,M),L=$E(L,M+1,999) Q . I $L($P(L," ",1,I))'>M D .. S N=N+1,A(N)=$P(L," ",1,I),L=$P(L," ",I+1,999) S A=N Q DDSOPT^INT^1^60335,48316^0 DDSOPT ;SFISC/MLH,MKO-SCREENMAN OPTIONS ;1MAR2006 ;;22.0;VA FileMan;**MSC**;Mar 30, 1999 0 S DIC="^DOPT(""DDS""," G OPT:$D(^DOPT("DDS",7)) S ^(0)="SCREENMAN OPTION^1.01" K ^("B") F X=1:1:7 S ^DOPT("DDS",X,0)=$P($T(@X),";;",2) S DIK=DIC D IXALL^DIK OPT ; S DIC(0)="AEQIZ" D ^DIC G Q:Y<0 S DI=+Y D EN G 0 ; EN ;Entry point for all screenman options D @DI W !! Q K %,DI,DIC,DIK,X,Y Q ; 1 ;;EDIT/CREATE A FORM CREATE G ^DDGF ; 2 ;;RUN A FORM G ^DDSRUN ; 3 ;;DELETE A FORM G ^DDSDFRM ; 4 ;;PURGE UNUSED BLOCKS G ^DDSDBLK ; 5 ;;PRINT A FORM G PRINT^DDS ; 6 ;;CUSTOMIZE COLORS D EDITPAR^XPAREDIT("DI SCREENMAN COLORS") Q ; 7 ;;CLONE A FORM D ^DDSCLONE DDSPRNT^INT^1^60300,29509^0 DDSPRNT ;SFISC/MKO-PRINT A FORM ;02:51 PM 18 Nov 1994 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU ; N DDSFORM,DDSPBRK D SELFORM(.DDSFORM) Q:DDSFORM=-1 D PAGEBRK(.DDSPBRK) Q:$D(DDSPBRK)[0 ; ;Device S %ZIS=$S($D(^%ZTSK):"Q",1:"") W ! D ^%ZIS K %ZIS I $G(POP) K POP Q K POP ; ;Queue report I $D(IO("Q")),$D(^%ZTSK) D G END . S ZTRTN="PRINT^DDSPRNT" . S ZTDESC="Report of Form "_$P(DDSFORM,U,2) . N I F I="DDSFORM","DDSFORM(0)","DDSPBRK" S ZTSAVE(I)="" . D ^%ZTLOAD . I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),! . E W !,"Report canceled!",! . K ZTSK . S IOP="HOME" D ^%ZIS ; U IO ; PRINT ;Entry point for queued reports N DDSBK,DDSCOL1,DDSCOL2,DDSCOL3,DDSCRT,DDSFILE N DDSHLIN,DDSHBK,DDSPAGE,DDSQUE N DX,DY,X,Y ; I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU D INIT D @("HDR"_(2-DDSCRT)) D FORM,END Q ; FORM ;Form data W ! ; ;Description D WP($NA(^DIST(.403,+DDSFORM,15))) Q:$D(DIRUT) ; ;Other properties D W("PRIMARY FILE: "_$P(DDSFORM(0),U,8),9) Q:$D(DIRUT) W ?49,"READ ACCESS: "_$P(DDSFORM(0),U,2) D W("DATE CREATED: "_$$EXTERNAL^DILFD(.403,4,"",$P(DDSFORM(0),U,5)),9) Q:$D(DIRUT) W ?48,"WRITE ACCESS: "_$P(DDSFORM(0),U,3) D W("DATE LAST USED: "_$$EXTERNAL^DILFD(.403,5,"",$P(DDSFORM(0),U,6)),7) Q:$D(DIRUT) W ?53,"CREATOR: "_$P(DDSFORM(0),U,4) D W() Q:$D(DIRUT) ; I $P(DDSFORM(0),U,7)]"" D W("TITLE: "_$P(DDSFORM(0),U,7),16) Q:$D(DIRUT) I $P($G(^DIST(.403,+DDSFORM,21)),U)]"" D W("RECORD SELECTION PAGE: "_$P(^(21),U)) Q:$D(DIRUT) ; I $X D W() Q:$D(DIRUT) S X=$G(^DIST(.403,+DDSFORM,11)) I X]"" D W("PRE ACTION:",11) Q:$D(DIRUT) D PCOL(X,23) S X=$G(^DIST(.403,+DDSFORM,12)) I X]"" D W("POST ACTION:",10) Q:$D(DIRUT) D PCOL(X,23) S X=$G(^DIST(.403,+DDSFORM,14)) I X]"" D W("POST SAVE:",12) Q:$D(DIRUT) D PCOL(X,23) S X=$G(^DIST(.403,+DDSFORM,20)) I X]"" D W("DATA VALIDATION:",6) Q:$D(DIRUT) D PCOL(X,23) K DDSFORM(0) ; ;Loop through all pages I $X D W() Q:$D(DIRUT) Q:'$O(^DIST(.403,+DDSFORM,40,0)) ; N DDSPG,DDSPGN S DDSPGN="",DDSPFRST=1 F S DDSPGN=$O(^DIST(.403,+DDSFORM,40,"B",DDSPGN)) Q:DDSPGN=""!$D(DIRUT) S DDSPG=0 F S DDSPG=$O(^DIST(.403,+DDSFORM,40,"B",DDSPGN,DDSPG)) Q:'DDSPG!$D(DIRUT) D PAGE^DDSPRNT1 K DDSPFRST Q:$D(DIRUT) ; D:$D(DDSHBK) HBLKS^DDSPRNT1 Q ; WR(DDSLAB,DDSVAL,DDSFLG) ;Write label and value I DDSVAL="",'$G(DDSFLG) Q ; D W() Q:$D(DIRUT) W ?DDSCOL2,DDSLAB ; I $X>DDSCOL3 N DDSCOL3 S DDSCOL3=$X+1 D PCOL(DDSVAL,DDSCOL3) Q ; PCOL(DDSVAL,DDSCOL) ;Print DDSVAL N DDSWIDTH,DDSIND S DDSWIDTH=IOM-DDSCOL-1 F DDSIND=1:DDSWIDTH:$L(DDSVAL) D Q:$D(DIRUT) . I DDSIND>1 D W() Q:$D(DIRUT) . W ?DDSCOL,$E(DDSVAL,DDSIND,DDSIND+DDSWIDTH-1) Q ; WP(DDSWP,DIWL,DDSLF) ;Print text in array @DDSWP ;DDSLF [ A : LF after (def) ; B : LF feed before ; Q:'$P($G(@DDSWP@(0)),U,3) N DIW,DIWF,DIWI,DIWR,DIWT,DIWTC,DIWX,DN N DDSI,DDSCNT,I,X,Z ; K ^UTILITY($J,"W") S:'$G(DIWL) DIWL=1 S DIWR=IOM-1 S:'$D(DDSLF) DDSLF="A" ; S DDSCNT=$P($G(@DDSWP@(0)),U,3) I DDSCNT D . F DDSI=1:1:DDSCNT I $D(@DDSWP@(DDSI,0))#2 S X=^(0) D ^DIWP . ; . I DDSLF'["B" D .. W ?DIWL-1,$G(^UTILITY($J,"W",DIWL,1,0)) .. S DDSCNT=1 . E S DDSCNT=0 . F S DDSCNT=$O(^UTILITY($J,"W",DIWL,DDSCNT)) Q:'DDSCNT!$D(DIRUT) D .. D W($G(^UTILITY($J,"W",DIWL,DDSCNT,0)),DIWL-1) ; K ^UTILITY($J,"W") D:DDSLF["A" W() Q ; W(DDSSTR,DDSCOL) ;Write DDSSTR I $Y+3'DDSCOL3 N DDSCOL3 S DDSCOL3=$X+1 D PCOL(DDSVAL,DDSCOL3) Q ; PCOL(DDSVAL,DDSCOL) ;Print DDSVAL starting in column DDSCOL N DDSWIDTH,DDSIND S DDSWIDTH=IOM-DDSCOL-1 F DDSIND=1:DDSWIDTH:$L(DDSVAL) D Q:$D(DIRUT) . I DDSIND>1 D W() Q:$D(DIRUT) . W ?DDSCOL,$E(DDSVAL,DDSIND,DDSIND+DDSWIDTH-1) Q ; W(DDSSTR,DDSCOL) ;Write DDSSTR preceded by !?DDSCOL I $Y+3'DDSCOL3 N DDSCOL3 S DDSCOL3=$X+1 D PCOL(DDSVAL,DDSCOL3) Q ; PCOL(DDSVAL,DDSCOL) ;Print DDSVAL starting in column DDSCOL N DDSWIDTH,DDSIND S DDSWIDTH=IOM-DDSCOL-1 F DDSIND=1:DDSWIDTH:$L(DDSVAL) D Q:$D(DIRUT) . I DDSIND>1 D W() Q:$D(DIRUT) . W ?DDSCOL,$E(DDSVAL,DDSIND,DDSIND+DDSWIDTH-1) Q ; W(DDSSTR,DDSCOL) ;Write DDSSTR preceded by !?DDSCOL I $Y+3'1 S D=D_",DIC(0)=""MF""",S=" D MIX^DIC1" .. E S D=D_",DIC(0)=""F""",S=" D IX^DIC" S:D="" D=",DIC(0)=""MF""",S=" D ^DIC" S D=D_" S:$G(DDS1E) DIC(0)=DIC(0)_""E"_$E("L",L)_"""" Q DDSR^INT^1^60300,29509^0 DDSR ;SFISC/MKO-PAINT ;18JAN2005 ;;22.0;VA FileMan;**999,1003,1004,1005,1007,1011**;Mar 30, 1999 R ;All pages ;Called after wp, mults, & deletions F DDSSC=1:1:DDSSC D RP(DDSSC(DDSSC),DDSSC=1) Q ; RP(X,DDS3LIN) ;Paint page ; X = DDSSC(DDSSC) node ; DDS3LIN = paint bottom line ; S DDS3P=$P(X,U),DDS3UL=$P(X,U,2),DDS3LR=$P(X,U,3) I DDS3UL="" W $P(DDGLCLR,DDGLDEL,2) E D ^DDSBOX(DDS3UL,DDS3LR) ; ;Write caps in "X" nodes D CAP^DDSR1 ; ;Paint data & exec caps ;Hdr blk S DDS3B=$P($G(^DIST(.403,+DDS,40,DDS3P,0)),U,2) D:DDS3B]"" DB(DDS3P,DDS3B) ; ;Other blks S DDS3BO="" F S DDS3BO=$O(^DIST(.403,+DDS,40,DDS3P,40,"AC",DDS3BO)) Q:'DDS3BO S DDS3B=$O(^(DDS3BO,"")) Q:'DDS3B D DB(DDS3P,DDS3B) K DDS3B,DDS3BO ; I DDS3LIN D . S DDSH=1,DX=0,DY=DDSHBX X IOXY W $TR($J("",IOM-1)," ","_") .I DDS3UL]"" S DY=DY+1 X IOXY W $P(DDGLCLR,DDGLDEL,3) N Y F Y=DY:1:IOSL K DDSMOUSE(Y) K DDS3P,DDS3UL,DDS3LR Q ; DB(DDS3P,DDS3B) ;Paint data K @DDSREFT@("XCAP",DDS3P,DDS3B) S DDS3=@DDSREFS@(DDS3P,DDS3B) S DDS3FN="F"_$P(DDS3,U,3),DDS3REP=$P(DDS3,U,7),DDS3PTB=$P(DDS3,U,8) K DDS3 ; I $G(DDS3REP)'>1 D . N DIE . S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B)) . S:DDS3DA]"" DIE=$G(@DDSREFT@(DDS3P,DDS3B,DDS3DA,"GL")) . S DDS3DDO=0 . F S DDS3DDO=$O(@DDSREFS@(DDS3P,DDS3B,DDS3DDO)) Q:DDS3DDO'=+DDS3DDO S DDS3C=$G(^(DDS3DDO,"D")) D:DDS3C]"" DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3PTB) . K DDS3C,DDS3DA,DDS3DDO E D DMULT(DDS3P,DDS3B,DDS3FN) ; K DDS3FN,DDS3PTB,DDS3REP Q ; DMULT(DDS3P,DDS3B,DDS3FN) ;Paint data, all lines N X,DIE S DDS3PDA=$P($G(@DDSREFT@(DDS3P,DDS3B)),U) GFT I '$D(^(DDS3B,"COMP MUL")),'DDS3PDA D . S X="",DDS3STL=1 . S DDS3NREP=$P(@DDSREFS@(DDS3P,DDS3B),U,7),DDS3SEL=$P(^(DDS3B),U,10) E D . S X=@DDSREFT@(DDS3P,DDS3B,DDS3PDA) . S DDS3STL=$P(X,U,3),DDS3NREP=$P(X,U,6),DDS3SEL=$P(X,U,9) ;3RD PIECE SAYS WHICH LINE IS NOW TOP LINE S DIE=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,"GL")) ; F DDS3LN=1:1:DDS3NREP D ;PAINT LINES ONE BY ONE . S DDS3SN=DDS3LN+DDS3STL-1 . S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN)) . S:DDS3LN=1 DDS3MORE=$S(DDS3STL>1:"+",1:" ") ;IF 1ST LINE ISN'T REALLY FIRST LAST . I DDS3LN=DDS3REP S DDS3MORE=" " I $D(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN+1))#2 S DDS3MORE="+",DDS3MORE("LAST")=1 ;IF LAST LINE ISN'T REALLY LAST . D DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,.DDS3MORE,DDS3SEL) . K DDS3MORE ; K DDS3DA,DDS3LN,DDS3NREP,DDS3PDA,DDS3SEL,DDS3SN,DDS3STL Q ; DMULTN(DDS3P,DDS3B,DDS3PDA,DDS3REP,DDS3LN) ;Paint lines from DDS3LN S DDS3FN="F"_$P(@DDSREFS@(DDS3P,DDS3B),U,3) S DDS3STL=$P(@DDSREFT@(DDS3P,DDS3B,DDS3PDA),U,3),DDS3SEL=$P(^(DDS3PDA),U,9) F DDS3LN=DDS3LN:1:DDS3REP D . S DDS3SN=DDS3LN+DDS3STL-1 . S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN)) . S:DDS3LN=1 DDS3MORE=$S(DDS3STL>1:"+",1:" ") . S:DDS3LN=DDS3REP DDS3MORE=$S($D(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN+1))#2:"+",1:" ") . D DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,.DDS3MORE,DDS3SEL) . K DDS3MORE K DDS3DA,DDS3FN,DDS3LN,DDS3SEL,DDS3SN,DDS3STL Q ; DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,DDS3MORE,DDS3SEL) ;Paint 1 line, LINE DDS3LN N DDSHITE S DDSHITE=$$HITE(DDS3B),DDS3DDO=0 F S DDS3DDO=$O(@DDSREFS@(DDS3P,DDS3B,DDS3DDO)) Q:DDS3DDO'=+DDS3DDO S DDS3C=$G(^(DDS3DDO,"D")) I DDS3C]"" D ;go thru fields in the multiple . S $P(DDS3C,U)=$P(DDS3C,U)+(DDS3LN-1*DDSHITE) ;DJW/GFT . S:$P(DDS3C,U,5)]"" $P(DDS3C,U,5)=$P(DDS3C,U,5)+(DDS3LN-1*DDSHITE) ;DJW/GFT . I $D(DDS3MORE),DDS3SEL=DDS3DDO,$P(DDS3C,U)?1.N D .. S DY=+DDS3C,DX=$P(DDS3C,U,2)-1 Q:DX<0 PLUSSIGN .. X IOXY D ...I DDS3MORE="+" S DDSMOUSE(DY,DX,DX)=$S($D(DDS3MORE("LAST")):"NP",1:"PP") I $G(DDSMOUSY) S DDS3MORE=$$HIGH^DDSU(DDS3MORE) ...W DDS3MORE . D DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,1,DDS3LN,DDS3SN) ;7TH parameter says ALWAYS PAINT AREA even if value is null K DDS3C,DDS3DDO Q ; HITE(BLK) N D,Z,H,L,F S D=1,H=1,L=999 F F=0:0 S F=$O(^DIST(.404,BLK,40,F)) Q:'F S Z=$G(^(F,2)) D .I 'Z S Z=$P(Z,U,3) ;MIGHT BE JUST A CAPTION .I Z S:ZH H=Z S D=H-L+1 ;GFT Q D ; ; DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3FLG,DDS3LN,DDS3SN) ; ;Paint field N DDS3FLD,DDS3LEN,DDSX D:$P(DDS3C,U,5)]"" XCAP ; S DY=+DDS3C,DX=$P(DDS3C,U,2) S DDS3LEN=$P(DDS3C,U,3),DDS3FLD=$P(DDS3C,U,4) ; ;Computed flds I DDS3DA]"",$P(DDS3C,U,9) S DDSX=$$VAL^DDSCOMP(DDS3DDO,DDS3B,DDS3DA) ; ;Form only flds Q:DDS3FLD="" I DDS3FLD'=+DDS3FLD N DDS3FN S DDS3FN="F0" ; ;External form S:DDS3FLD DDSX=$S(DDS3DA="":"",$D(@DDSREFT@(DDS3FN,DDS3DA,DDS3FLD,"X"))#2:^("X"),1:$G(^("D"))) PAINT D ;I $G(DDSX)]""!$G(DDS3FLG) D PAINT NULL FIELD TO SHOW COLOR . S:$D(DDSX)[0 DDSX="" . X IOXY . I '$P(DDS3C,U,10) S DDSX=$E(DDSX,1,DDS3LEN)_$J("",DDS3LEN-$L(DDSX)) . E S DDSX=$J("",DDS3LEN-$L(DDSX))_$E(DDSX,1,DDS3LEN) . W $P(DDGLVID,DDGLDEL)_DDSX_$P(DDGLVID,DDGLDEL,10) Q ; XCAP ;Paint exec caps N Y,DDSLN,DDSSN I 'DDS3DA N DA,D0 S (DA,D0)="" ; I DDS3DA N DDSDL S DDSDL=$L(DDS3DA,",")-2 I N DA,@$$D0^DDS(DDSDL) I D BLDDA^DDS(DDS3DA) ; S DDS3TP=$P($G(@DDSREFS@(DDS3P,DDS3B)),U,5) S DDS3L0=$G(^DIST(.404,DDS3B,40,DDS3DDO,0)) G:DDS3L0?."^" XCAPQ S DDS3L01=$G(^DIST(.404,DDS3B,40,DDS3DDO,.1)) G:DDS3L01?."^" XCAPQ ; S:$D(DDS3LN) DDSLN=DDS3LN S:$D(DDS3SN) DDSSN=DDS3SN ; X DDS3L01 G:$G(Y)="" XCAPQ S DDS3CAP=Y ; I DDS3TP="e","^2^3^"[(U_$P(DDS3L0,U,3)_U)!'$P(DDS3L0,U,3) D . S Y=$$UP^DILIBF(Y) ;** . S @DDSREFT@("XCAP",DDS3P,Y,DDS3B,DDS3DDO)="" ; S DY=$P(DDS3C,U,5),DX=$P(DDS3C,U,6) S DDS3CAP=DDS3CAP_$P(DDS3C,U,7) S:$P(DDS3C,U,8) DDS3CAP=$P(DDGLVID,DDGLDEL,4)_DDS3CAP_$P(DDGLVID,DDGLDEL,10) X IOXY W DDS3CAP XCAPQ K DDS3CAP,DDS3L0,DDS3L01,DDS3TP Q DDSR1^INT^1^60300,29509^0 DDSR1 ;SFISC/MKO-PAINT ;11AUG2004 ;;22;;**999,1003,1005**;Dec 28, 1994 ; CAP ;Write captions in "X" nodes N DDGLVAN S DDGLVAN=1 ;** DEFEAT OLD LOGIC ABOUT LO-INTENSITY W:$D(DDGLVAN) $P(DDGLVID,DDGLDEL,2) ; EGP N DDCAP,A,C,C1,C2,P,PC,V,X ;**CCO/NI I $G(DUZ("LANG"))>1 S DY=$NA(@DDSREFS@("CAP")) F S DY=$Q(@DY) Q:$QS(DY,4)'="CAP" D ;IF WE HAVE A FIELD WITH A FOREIGN LABEL ENTERED, USE IT .I $QS(DY,7)=DDS3P S C1=+$QS(DY,8),C2=$P($G(@DDSREFS@(DDS3P,C1)),U,3) I C2 S X=$G(^(C1,+$QS(DY,9),"D")),A=$P(X,U,4) I A S P=$P($G(^DD(C2,A,0)),U),A=$$LABEL^DIALOGZ(C2,A) I A]"",A'=P S DDCAP($$UP^DILIBF($QS(DY,5)))=A S DY="" F S DY=$O(@DDSREFS@("X",DDS3P,DY)) Q:DY="" S DX=$O(^(DY,"")),DDS3CAP=^(DX) D X IOXY W DDS3CAP .I $G(DUZ("LANG"))>1 D ..;I $D(@DDSREFS@("X",DDS3P,DY,DX,"LANG",DUZ("LANG"))) S DDS3CAP=^(DUZ("LANG")) Q ..S C="",C2=$$UP^DILIBF(DDS3CAP) F S C=$O(DDCAP(C)) Q:C="" D ...S C1=$L(C),P=$F(C2,C) I P S $E(DDS3CAP,P-C1,P-1)=$E(DDCAP(C)_$J("",80),1,C1) ;COULD FIND "NAME" IN "FATHER'S NAME" AND REPLACE IT WITH "NOBRE"! ..Q ..S C=DDS3CAP,C1=C?.E1":" I C1 S C=$E(C,1,$L(C)-1) . Q:'$D(@DDSREFS@("X",DDS3P,DY,DX,"A")) S A=^("A") . S X=DDS3CAP,DDS3CAP="",P=1 . F PC=1:1:$L(A,U) S C=$P(A,U,PC) D:C]"" .. S C1=$P(C,";"),C2=$P(C,";",2) .. S V=$S($P(C,";",3)="U":$P(DDGLVID,DDGLDEL,4),1:"") .. S DDS3CAP=DDS3CAP_$E(X,P,C1-1)_V_$E(X,C1,C2)_$P(DDGLVID,DDGLDEL,10)_$S($D(DDGLVAN):$P(DDGLVID,DDGLDEL,2),1:"") .. S P=C2+1 . S DDS3CAP=DDS3CAP_$E(X,P,999) ; W:$D(DDGLVAN) $P(DDGLVID,DDGLDEL,10) K DDS3CAP Q DDSRP^INT^1^61593,53333^0 DDSRP(DDS,DDS3P,DDSJ) ;GFT -- PRINT FORM 'DDS', PAGE 'DDS3P';20JUL2009 ;;22.0;;**1003,1014,1035** I '$G(DDSJ) S DDSJ=$J N X,Y,IOP,POP,BLK,DDSREFS,DDSREFT S DDSREFT=$NA(^TMP("DDS",DDSJ,DDS)) S DDSREFS=$NA(^DIST(.403,+DDS,"AY")) K ^UTILITY($J,"DDSRP") S IOP="P" D ^%ZIS I POP D HLP^DDSUTL("SORRY, I CANNOT FIND YOUR PRINTER") Q D HLP^DDSUTL("PRINTING TO "_IO_" ...") U IO D CAP,BLKS,PRINT Q BLKS ;FROM ^DDSR S BLK=$P($G(^DIST(.403,+DDS,40,DDS3P,0)),U,2) ;Hdr blk D:BLK]"" DB(DDS3P,BLK) ; ;Other blks N DDS3BO S DDS3BO="" F S DDS3BO=$O(^DIST(.403,+DDS,40,DDS3P,40,"AC",DDS3BO)) Q:'DDS3BO S BLK=$O(^(DDS3BO,"")) Q:'BLK D DB(DDS3P,BLK) Q ; PRINT ; N DDSI S DDSI=1 F Y=0:1:$O(^UTILITY($J,"DDSRP",""),-1) W !,$G(^UTILITY($J,"DDSRP",Y)) S DDSI=DDSI+1 I $G(IOSL),DDSI'1 D . N DIE . S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B)) . S:DDS3DA]"" DIE=$G(@DDSREFT@(DDS3P,DDS3B,DDS3DA,"GL")) . S DDS3DDO=0 . F S DDS3DDO=$O(@DDSREFS@(DDS3P,DDS3B,DDS3DDO)) Q:DDS3DDO'=+DDS3DDO S DDS3C=$G(^(DDS3DDO,"D")) D:DDS3C]"" DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3PTB) . K DDS3C,DDS3DA,DDS3DDO E D DMULT(DDS3P,DDS3B,DDS3FN) ; K DDS3FN,DDS3PTB,DDS3REP Q ; DMULT(DDS3P,DDS3B,DDS3FN) ;Paint data, all lines N X,DIE S DDS3PDA=$P($G(@DDSREFT@(DDS3P,DDS3B)),U) GFT I '$D(^(DDS3B,"COMP MUL")),'DDS3PDA D . S X="",DDS3STL=1 . S DDS3NREP=$P(@DDSREFS@(DDS3P,DDS3B),U,7),DDS3SEL=$P(^(DDS3B),U,10) E D . S X=@DDSREFT@(DDS3P,DDS3B,DDS3PDA) . S DDS3STL=$P(X,U,3),DDS3NREP=$P(X,U,6),DDS3SEL=$P(X,U,9) ;3RD PIECE SAYS WHICH LINE IS NOW TOP LINE S DIE=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,"GL")) ; F DDS3LN=1:1:$O(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,"A"),-1) D ;PAINT LINES ONE BY ONE . S DDS3SN=DDS3LN ;START WITH LINE 1 ALWAYS . S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN)) . D DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,DDS3SEL) F DDS3LN=DDS3LN+1:1:DDS3REP S DY=DY+1,DX=2 D PUT(" ") ;BLANK LINES AT END OF MULTIPLES K DDS3DA,DDS3LN,DDS3NREP,DDS3PDA,DDS3SEL,DDS3SN,DDS3STL Q ; DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,DDS3SEL) ;Paint 1 line, LINE DDS3LN N DDSHITE S DDSHITE=$$HITE^DDSR(DDS3B),DDS3DDO=0 F S DDS3DDO=$O(@DDSREFS@(DDS3P,DDS3B,DDS3DDO)) Q:DDS3DDO'=+DDS3DDO S DDS3C=$G(^(DDS3DDO,"D")) I DDS3C]"" D . S $P(DDS3C,U)=$P(DDS3C,U)+(DDS3LN-1*DDSHITE) ;DJW/GFT . S:$P(DDS3C,U,5)]"" $P(DDS3C,U,5)=$P(DDS3C,U,5)+(DDS3LN-1*DDSHITE) ;DJW/GFT . D DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,1,DDS3LN,DDS3SN) K DDS3C,DDS3DDO Q ; DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3FLG,DDS3LN,DDS3SN) ;Paint field N DDS3FLD,DDS3LEN,DDSX D:$P(DDS3C,U,5)]"" XCAP ; S DY=+DDS3C,DX=$P(DDS3C,U,2) S DDS3LEN=$P(DDS3C,U,3),DDS3FLD=$P(DDS3C,U,4) ; ;Computed flds I DDS3DA]"",$P(DDS3C,U,9) S DDSX=$$VAL^DDSCOMP(DDS3DDO,DDS3B,DDS3DA) ; ;Form only flds Q:DDS3FLD="" I DDS3FLD'=+DDS3FLD N DDS3FN S DDS3FN="F0" ; ;External form S:DDS3FLD DDSX=$S(DDS3DA="":"",$D(@DDSREFT@(DDS3FN,DDS3DA,DDS3FLD,"X"))#2:^("X"),1:$G(^("D"))) I $G(DDSX)]""!$G(DDS3FLG) D . S:$D(DDSX)[0 DDSX="" . I '$P(DDS3C,U,10) S DDSX=$E(DDSX,1,DDS3LEN)_$J("",DDS3LEN-$L(DDSX)) . E S DDSX=$J("",DDS3LEN-$L(DDSX))_$E(DDSX,1,DDS3LEN) . D PUT(DDSX) Q ; XCAP ;Paint exec caps N Y,DDSLN,DDSSN I 'DDS3DA N DA,D0 S (DA,D0)="" ; I DDS3DA N DDSDL S DDSDL=$L(DDS3DA,",")-2 I N DA,@$$D0^DDS(DDSDL) I D BLDDA^DDS(DDS3DA) ; S DDS3TP=$P($G(@DDSREFS@(DDS3P,DDS3B)),U,5) S DDS3L0=$G(^DIST(.404,DDS3B,40,DDS3DDO,0)) G:DDS3L0?."^" XCAPQ S DDS3L01=$G(^DIST(.404,DDS3B,40,DDS3DDO,.1)) G:DDS3L01?."^" XCAPQ ; S:$D(DDS3LN) DDSLN=DDS3LN S:$D(DDS3SN) DDSSN=DDS3SN ; X DDS3L01 G:$G(Y)="" XCAPQ S DDS3CAP=Y ; I DDS3TP="e","^2^3^"[(U_$P(DDS3L0,U,3)_U)!'$P(DDS3L0,U,3) D . S Y=$$UP^DILIBF(Y) ;** . S @DDSREFT@("XCAP",DDS3P,Y,DDS3B,DDS3DDO)="" ; S DY=$P(DDS3C,U,5),DX=$P(DDS3C,U,6) S DDS3CAP=DDS3CAP_$P(DDS3C,U,7) D PUT(DDS3CAP) XCAPQ K DDS3CAP,DDS3L0,DDS3L01,DDS3TP Q ; PUT(X) S $E(^UTILITY($J,"DDSRP",DY),DX+1,DX+$L(X))=X Q ; DDSRSEL^INT^1^60300,29510^0 DDSRSEL ;SFISC/MKO-RECORD SELECTION ;7JAN2004 ;;22.0;VA FileMan;**1003**;Mar 30, 1999 ; PG ;Called from: ; DDS01 when user presses SELECT ; FIRSTPG^DDS0 if no DA was passed in. ; ;Returns (if there is a record selection page and we're not in ;a multiple) ; DDSPG = Record selection page # ; DDACT = "NP" ; DDSSEL = 1 (undefined if no record selection page) ; N P,P1 K DDSSEL I $D(DDSSC),$P($G(DDSSC(DDSSC)),U,4) Q ;GFT ; S P="",P1=$P($G(^DIST(.403,+DDS,21)),U) I P1]"" D . S P=$O(^DIST(.403,+DDS,40,"B",P1,"")) . I P]"",$D(^DIST(.403,+DDS,40,P,0))[0 S P="" ; I P]"" D . I $G(DDO),$G(DDSDN)=1 D .. D ERR3^DDS3 . E S DDSPG=P,DDACT="NP",DDSSEL=1 Q ; GDA ;Called from DDS ;After a record selection page is closed get the DA from ;the first field on the page. N DDSANS,DDSREC,Y,PG S DDSANS="" GFT S PG=$P($G(^DIST(.403,+DDS,21)),U) G KILL:'PG N P S P=$O(^(40,"B",PG,0)) D:P I '$D(Y) G KILL .F Y=0:0 S Y=$O(^DIST(.403,+DDS,40,P,40,Y)) Q:'Y I $G(^(Y,"COMP MUL"))]"" K Y Q E S DDSREC=$$GET^DDSVALF(1,1,PG) ;ON THE OLD KIND OF LOOKUP PAGE, THERE IS 1 FIELD, 1 BLOCK ; K DA,DDSDAORG S DDSDA=DDSDASV,DDSDL=DDSDLSV D BLDDA^DDS(DDSDA) M DDSDAORG=DDSORGSV ; I 'DDSREC,DA S DDSREC=DA E I DDSREC,DDSREC'=DA D . I DA D Q:DDSREC=DA .. S DDSANS=$$ASKSAVE .. I DDSANS="R" S DDSREC=DA .. E I DDSANS="S" D ... D ^DDS4 ... S:Y'=1 DDSREC=DA . ; . S DA=DDSREC . D REC^DDS0(DDP,.DA) . ; . I $G(DIERR) D Q .. D ERR^DDSMSG H 2 .. S DA=+$G(DDSDASV),DDACT="N" .. D REC^DDS0(DDP,.DA) . ; . S DDACT="N" . I DDSSC=1 D FRSTPG^DDS0(DDS,.DA,$G(DDSPAGE)) . D CLRDAT,UNLOCK ; KILL K DDSSEL,DDSDASV,DDSDASV,DDSDLSV,DDSORGSV Q ; ASKSAVE() ; ;Ask user whether to save the previous record N X,Y D:DDM CLRMSG^DDS S DDM=1 ; K DIR S DIR(0)="SM^S:SAVE;D:DISCARD;R:RETURN" S DIR("A",1)=" NOTE: You must Save or Discard all edits to the" S DIR("A",2)=" previous record before editing the next record." S DIR("A",3)=" " S DIR("A")="Save, Discard, or Return (S/D/R)" S DIR("B")="SAVE" ; S DIR("?",1)="Enter 'S' to save or 'D' to discard." S DIR("?")="Enter 'R' or '^' to return to previous record." ; S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^7^"_(IOSL-4)_"^0" D ^DIR I $D(DIRUT) S Y="R" E I X="SAVE" S Y="S" K DIR,DIROUT,DIRUT,DTOUT,DUOUT Q Y ; CLRDAT ;Clear all data values from @DDSREFT N F,P S P=0 F S P=$O(@DDSREFT@(P)) Q:'P K @DDSREFT@(P) S F="F" F S F=$O(@DDSREFT@(F)) Q:$E(F)'="F" K @DDSREFT@(F) Q ; UNLOCK ;Unlock all records locked Q:'$D(^TMP("DDS",$J,"LOCK")) N I S I="" F S I=$O(^TMP("DDS",$J,"LOCK",I)) Q:I="" D . I I'=(DIE_DA_")") L -@I K ^TMP("DDS",$J,"LOCK",I) Q DDSRUN^INT^1^60300,29510^0 DDSRUN ;SFISC/MKO-RUN A FORM ;8DEC2003 ;;22.0;VA FileMan;**1003**;Mar 30, 1999 ; ;Select file (DDSFILE) EGP S DDS1=8108.3 D W^DICRW K DDS1 G:Y<0 RUNQ ;**CCO/NI 'RUN FORM:' G:'$D(@(DIC_"0)")) RUNQ K DDSFILE S DDSFILE=+Y ; ;Select form (DDSRUNDR) K DIC S DIC=.403,DIC(0)="QEA",D="F"_+Y S DIC("S")="I $P(^(0),U,8)=+DDSFILE" I DUZ(0)'="@" S DIC("S")=DIC("S")_" N DDSI F DDSI=1:1:$L($P(^(0),U,2)) I DUZ(0)[$E($P(^(0),U,2),DDSI) Q" W ! D IX^DIC K DIC,D G:Y<0 RUNQ S DDSRUNDR=+Y ; I '$$COMPILED^DDS0(DDSRUNDR) D EN^DDSZ(DDSRUNDR) G:$G(DIERR) RUNQ ; ;Select page (DDSPAGE) PAGE K DIR S Y=$O(^DIST(.403,DDSRUNDR,40,0)) I '$O(^(Y)) S DDSPAGE=1 G REC ;DON'T ASK IF ONLY ONE! S Y=$G(^DIST(.403,DDSRUNDR,21)) I Y S DDSPAGE=+Y G REC ;IF THERE'S A RECORD SELECTION PAGE, USE IT S DIR(0)="NOA^1:999.9:1" S DIR("A")="Enter number of first page: ",DIR("B")=1 W ! D ^DIR K DIR G:$D(DIRUT) RUNQ K DDSPAGE S:Y'=1 DDSPAGE=Y ; REC ;Select record (DA) K DA I '$P(^DIST(.403,DDSRUNDR,0),U,10),$S($G(DDSPAGE):$G(^(21))-DDSPAGE,1:1) D G:DA<0 RUNQ ;IF IT'S A RECORD SELECTION PAGE, THAT WILL FIND 'DA' . S DIC=DDSFILE,DIC(0)="QEALM" . W ! D ^DIC K DIC . S DA=+Y K D,DIC,X,Y ; ;Invoke form K DR S DR=DDSRUNDR D ^DDS G:$D(DA) REC ; RUNQ ;Clean up and quit I $D(DIERR) W !,$C(7) D MSG^DIALOG("BW") K D,DIC,X,Y K DDSFILE,DDSPAGE,DDSRUNDR,DA,DR K DIRUT,DTOUT,DUOUT Q DDSSTK^INT^1^61069,61055^0 DDSSTK ;SFISC/MKO-STACK CONTEXT, GO TO A NEW PAGE ;19JUNE2007 ;;22.0;VA FileMan;**1028**;Mar 30, 1999 N DDO N DDSBK,DDSDN,DDSFLD,DDSNP,DDSOPB,DDSPG,DDSPTB,DDSREP,DDSTP ; I DDSSTACK?1"`".E D . S DDSSTACK=+$E(DDSSTACK,2,999) E I DDSSTACK=+$P(DDSSTACK,"E") D . S DDSSTACK=+$O(^DIST(.403,+DDS,40,"B",DDSSTACK,"")) E D UP . S DDSSTACK=$O(^DIST(.403,+DDS,40,"C",$$UP^DILIBF(DDSSTACK),"")) ;** ; I 'DDSSTACK!($D(^DIST(.403,+DDS,40,+$G(DDSSTACK),0))[0) D Q . K DDSSTACK,DDSBR ; N DDSDAORG,DDSDLORG,DDSFLORG,DDSPG N:'$P(^DIST(.403,+DDS,40,+$G(DDSSTACK),0),U,6) DDSSC ;N DDSSC (Page array) if not going to a POPUP PAGE ; S DDSPG=DDSSTACK K DDSSTACK,DDSBR ; S DDSDLORG=DDSDL,DDSDAORG=DA F DDSI=1:1:DDSDL S DDSDAORG(DDSI)=DA(DDSI) K DDSI ; DDSH S DDSSTK=1,DDSH=1 ;DDSH tells SM+6^DIR0 to refresh the COMMAND LINE D PROC^DDS Q DDSU^INT^1^60300,29510^0 DDSU ;SFISC/MLH-PROCESS HELP ;11NOV2004 ;;22.0;VA FileMan;**4,3,54,999,1001,1004,1005,1007**;Mar 30, 1999 LIST ; I '$D(DDS) D Q FM .;FileMan help - Non screen .N A0,A1,A2,A3,A4,DDSDIW,DDSDIY,Y .S A0="" .F S A0=$O(DDH(A0)) Q:'A0 S DDSDIW=$X,DDSDIY=$Y D W I $G(DDD)>2,DDSDIW-$X!(DDSDIY-$Y) D STP Q:$D(DTOUT) .I $G(DIPGM)="DICQ1",$G(DP),$G(DIC("?N",DP)) D ..N DIZ S DIZ=0 D T Q Q .I '$D(DTOUT) D SV S DDH=0 Q .K DDH D:'DTOUT Q ..K DTOUT N % S %=$G(DIPGM) I %'="DICQ1",%'="DIEQ" Q ..S DUOUT=1 ; ;SCREENMAN HELP N DIR0A K DICQRETA,DICQRETV D SC I $D(DIR0A) S DICQRETV=DIR0A ;RETURN VALUE from MOUSE Q ; SC ;Screen Help, also from DDS2,DDSCOM,DDSMSG N A0,A1,A2,A3,A4,A5,A6,DDSB1,X,Y K DTOUT,DUOUT ; W $P(DDGLVID,DDGLDEL,9) S X=$G(IOM,80)-1 X ^%ZOSF("RM") I $D(DDQ)#2,DDQ<(IOSL-1),DDQ>DDSHBX!$P(DDQ,U,2)!$D(DDIOL) S DY=$P(DDQ,U),DX=$P(DDQ,U,2) E D CLRMSG^DDS S DY=DDSHBX X DDXY ; S:$G(DDD,5)=5 DDD=1 S:$D(DDO) DDSB1=DDO S DDM=1,DDO=.5 S (A0,DIY,X)="",A1=0,A5=$S(DDD=2:$O(DS(0)),1:$O(DDH(A0))) K A2,DDSQ ;Now loop thru the DDHs F D Q:DDO'<1!(X=U)!'A0!DIY!$D(DTOUT)!$D(DUOUT)!$D(DIR0A) SC1 .S A6=A0,A0=$O(DDH(A0)) S:A6="" A6=A0-1 .I 'A0,DDD Q:DDD=1 Q:DDDDSHBX) S DY=DY+1 X DDXY .I A4="E" D SC2 Q MORE .I $Y'<(IOSL-2)!'A0 D SC2 Q:DDO'<1!(X=U)!'A0!DIY!$D(DTOUT)!$D(DUOUT)!$D(DIR0A) S DY=DDSHBX+1,DX=0 X DDXY .Q:A4="" .D WR ;Write something! .I $Y'<(IOSL-1),'$D(DTOUT),'$D(DUOUT) D Q ;SEE IF WE ARE 2 LINES FROM BOTTOM ..W ! S A6=A0 D SC2 ;Now that we have written choice #A0, allow then to choose it ..W $P(DDGLVID,DDGLDEL,8) S X=0 X ^%ZOSF("RM") D REFRESH^DDSUTL ..W $P(DDGLVID,DDGLDEL,9) S X=$G(IOM,80)-1 X ^%ZOSF("RM") ..S DX=0,DY=DDSHBX X DDXY .S DY=$Y,DX=0 I $D(DDSB1) S:DDO<1 DDO=DDSB1 E K DDO ; S %=0 S DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)_U_DX S:DDQ>DDSHBX DDM=1 I $D(A2) K DDD,DDH,DDQ S %=A2 S:%'=1 DDSQ=1 D CLRMSG^DDS G QQ I $D(DDC),DDC'<0 D SV E K DDD,DDH S DDSQ=1 ;DDSQ means we're done with the Lister ; QQ S A0=$X S X=0 X ^%ZOSF("RM") W $P(DDGLVID,DDGLDEL,8) S $X=A0 Q ; ; SC2 S DX=0,DY=IOSL-1 X DDXY I DDD=1 W $$EZBLD^DIALOG(8053) D READ Q ;DDD=1 means 'HIT RETURN to CONTINUE' W $$EZBLD^DIALOG(8081,A5_"-"_A6)_$P(DDGLCLR,DDGLDEL) ;CHOOSE 1-3 ... D READ I $G(DUOUT) K DDC G Q2 I X]"",XA6) W $C(7) G SC2 E I X S:DDD["J" DDO=$O(DDH(X,"")) K DDC D CLRMSG^DDS S DDM=1 Q2 S DIY=X,DY=DDSHBX Q ; ; SV ;Kill DDH array, but save the "ID" nodes and DDH itself K A1,A2 S:$D(DDH("ID")) A1=DDH("ID") S:$D(DDH("ID",1)) A2=DDH("ID",1) K DDH S DDH=0 S:$D(A1) DDH("ID")=A1 S:$D(A2) DDH("ID",1)=A2 Q ; ; ; Z ;From DICQ1,DIEQ D Y,T Q ; Y D:'$D(DISYS) OS^DII S $X=0,$Y=0 S DIZ=$S($D(DILN)&'$D(DIR0):DILN,$G(IOSL):IOSL-3,1:21) ;** Q ; ; ; STP Q:$D(DD)[0!($D(DIY)[0) I DD+DIY'>79 W ?DD S DD=DD+DIY Q ; T W !?3 S DD=DIY+3 I $Y>DIZ!'$Y D .W $$EZBLD^DIALOG(8053) R %Y:$G(DTIME,300) ;** . E S DTOUT=1 K DDD . W $C(13),$J("",15),$C(13) Q:$D(DTOUT) . I %Y[U S DTOUT=0 K DDD . D Y W ?3 Q ; W S A4=$O(DDH(A0,"")) Q:A4="" Q:DDH(A0,A4)="" W:'$D(DDD) ! I $G(DDD)=3,A4["T" K DDD ; WR I A4["X" D Q . N DDD,DIY,DDSXEC . S DDSXEC=DDH(A0,A4) . N DDH . I $D(DDS) N DDSID S DDSID=1 S DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)_U_DX . X DDSXEC ; I A4["Q" D Q . S A4=DDH(A0,A4),%=$P(A4,U,1) . I $D(DDS) D ASK Q . W $P(A4,U,2) . D YN^DICN ; I A4["T" D Q . I DDH(A0,A4)[$C(0) D .. S DX=$L(DDH(A0,A4),$C(0))-1 .. X DDXY .. S DDH(A0,A4)=$TR(DDH(A0,A4),$C(0),"") . W DDH(A0,A4) ; I '$D(DDS),$G(DDD)'["J",A4'=+A4 Q I $D(DDS),$G(DDD)=2!($G(DDD)["J") W A0,?7 ; CHOICE I $D(DDS),$G(DDSMOUSY) D .W " " D WRITMOUS(DDH(A0,A4)) E W DDH(A0,A4) I $D(DDH("ID")) D S:$D(DUOUT) DIY=U . N DDD,DIY,DDSID . S DDSID=DDH("ID") . S:$D(DDH("ID",1))#2 DDSID(1)=DDH("ID",1) . N DDH . S:$D(DDSID(1))#2 DDH("ID",1)=DDSID(1) K DDSID(1) . S Y=A4 . S:$D(DDS) DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)_U_$X . X DDSID Q ; ; WRITMOUS(C) ;MAKE THE CHOICES IN THE COMMAND AREA CLICKABLE!! W $P(DDGLCLR,DDGLDEL) N F F Q:$A(C)-32 S C=$E(C,2,999) W " " ;LEADING BLANKS F F=0:1 Q:$A(C,$L(C))-32 S C=$E(C,1,$L(C)-1) I $G(DDSMOUSY) S DDSMOUSE($Y,$X,$X+$L(C)-1,1)=C W $$HIGH(C) E W C W $J("",F) Q ; ; ; HIGH(X) ;also from DDSCOM, DDSR I '$D(DDGLVID) Q X Q $P(DDGLVID,DDGLDEL,10)_$P(DDGLVID,DDGLDEL,6)_X_$P(DDGLVID,DDGLDEL,10) ; ; ; ASK W $P(A4,U,2)_$S(%'>2:"? ",1:"")_$S(%>0&(%<3):$P($$EZBLD^DIALOG(7001),U,%)_"// ",1:"")_$P(DDGLCLR,DDGLDEL) S A2=0 D READ I $G(DUOUT) S A2=-1 Q I %>2 S A2=X Q N %1 S %1=$$PRS^DIALOGU(7001,X) S:%1>0 X=$E($P(%1,U,2)) K %1 I "YyNn^"'[X W $C(7) X DDXY G ASK I X]"","^Nn"[X S A2=2 K DDC Q S:"Yy"[X A2=1 S:X=""&(%]"") A2=+% S DDD=1 Q ; ; READ ;RETURNS 'X' & 'DICQRETA' N DIR0P,DIR0KD,S X DDGLZOSF("EOFF") S (DIR0P,X)="" F D Q:'$D(S) .D READ^DIR01(.S) I S="TO" S DTOUT=1 K DCC G Q2 .I $L(S)=1 S X=X_S W S Q .I S="CR" K S Q .I S="EX"!(S="SV")!(S="QT") S DICQRETA=S,DUOUT=1,X=U K S Q .I S="MOUSEDN" Q ;ignore down-click .I S="MOUSE" K S D MOUSE^DIR01 K:$G(DIR0A)?."??" DIR0A S DUOUT=1,DDSQ=1 Q .W *7 X DDGLZOSF("EON") I X?1."^" S DUOUT=1,X=U Q D CLRMSG^DDS S DDM=1 Q ; ; ; ; H ;From DICN S:'$D(A1) A1="T" S DDH=$G(DDH)+1,DDH(DDH,A1)=DST K A1,DST D SC Q ;#8053 Press 'RETURN' to continue... ;#8081 Choose |from-to| or '^'... ;#7001 Yes^No DDSUTL^INT^1^60300,29510^0 DDSUTL ;SFISC/MKO-PROGRAMMER UTILITIES ;11:37 AM 25 Jul 1995 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; MSG(TXT) ; ;Data validation messages D PROC(.TXT,$NA(@DDSREFT@("MSG"))) Q ; HLP(TXT) ; ;Help box messages D PROC(.TXT,$NA(@DDSREFT@("HLP"))) Q PROC(TXT,GLB) ; ;Put text into global N CNT,I S CNT=$G(@GLB) I $D(TXT)<9 S CNT=CNT+1,@GLB@(CNT)=TXT E S I="" F CNT=CNT:1 S I=$O(TXT(I)) Q:I="" S @GLB@(CNT+1)=TXT(I) S @GLB=CNT Q ; REFRESH ;Refresh the screen G R^DDSR ; MLOAD(DDSIEN) ;Load subrecords for current multiple G MLOAD^DDSM1 ; MDEL(DDSIEN) ;Delete subrecords for current multiple G MDEL^DDSM1 ; UNED(DDSF,DDSB,DDSP,DDSVAL,DDSUDA) ;Change DISABLE EDITING attribute S:$D(DDSVAL)[0 DDSVAL="" D SETATT(4) Q ; REQ(DDSF,DDSB,DDSP,DDSVAL,DDSUDA) ;Change REQUIRED attribute S:$D(DDSVAL)[0 DDSVAL="" D SETATT(1) Q ; ; SETATT(DDSUPC) ;Set attribute node, piece DDSUPC N DDSOVAL,DDSUDDP,DDSUFLD,DDSUTP I $D(DDSPG)[0 N DDSPG S DDSPG="" I $D(DDSBK)[0 N DDSBK S DDSBK="" S DDSP=$$GETFLD^DDSLIB(DDSF,$G(DDSB),$G(DDSP),+DDS,DDSPG,DDSBK) I $G(DIERR) D ERR^DDSMSG Q ; S DDSF=$P(DDSP,","),DDSB=$P(DDSP,",",2),DDSP=$P(DDSP,",",3) ; S DDSUDDP=+$P($G(^DIST(.404,DDSB,0)),U,2) I DDSUDDP,$G(DDSUDA)]"" N DDSDA S DDSDA=DDSUDA E I DDSUDDP,DDSB'=DDSBK N DDSDA D GL^DDS10(DDSUDDP,.DDSDAORG,"","",.DDSDA) ; S DDSUTP=$P($G(^DIST(.404,DDSB,40,DDSF,0)),U,3) S:'DDSUTP DDSUTP=3 I DDSUTP=2 D . S DDSUFLD=DDSF_","_DDSB . S DDSUDDP=0 E I DDSUTP=3 D Q:'DDSUFLD . S DDSUFLD=$P($G(^DIST(.404,DDSB,40,DDSF,1)),U) E Q ; S DDSOVAL=$P($G(@DDSREFT@("F"_DDSUDDP,DDSDA,DDSUFLD,"A")),U,DDSUPC) Q:DDSVAL=DDSOVAL S $P(@DDSREFT@("F"_DDSUDDP,DDSDA,DDSUFLD,"A"),U,DDSUPC)=DDSVAL Q ; ADD(DDSFIL,X,DA,DINUM,DDSDIC0,DDSDR,DDSL) ; ;Add an entry as part of a transaction ;DDSL=1 means don't lock ; N %,%W,%Y,C,D0,DD,DO,DI,DIC,DIE,DQ,DR N DDSDA,DDSDIC,DDSFD,DDSREQ,DDSUP,I K DIERR,^TMP("DIERR",$J) K:'$G(DINUM) DINUM S:$G(DDSDIC0)="" DDSDIC0="L" S DIC(0)=DDSDIC0,Y=-1 S:$G(DDSDR)]"" DIC("DR")=DDSDR S DIC=$$ROOT^DILFD(DDSFIL,.DA),DDSDIC=$$CREF^DIQGU(DIC) ; I $D(@DDSDIC@(0))[0 D Q:$G(DIC("P"))="" . S DDSUP=$G(^DD(DDSFIL,0,"UP")) Q:'DDSUP . S DDSFD=$O(^DD(DDSUP,"SB",DDSFIL,"")) Q:'DDSFD . S DIC("P")=$P($G(^DD(DDSUP,DDSFD,0)),U,2) ; I DDSDIC0'["E",$$REQID(DDSFIL,.DDSREQ) D Q:$G(DIERR) . N F . S F="" . F S F=$O(DDSREQ(F)) Q:'F I $G(DIC("DR"))'[(F_"///") D BLD^DIALOG(3031,"ADD^DDSUTL") Q ; D FILE^DICN K DTOUT,DUOUT Q:Y=-1!'$D(DDS) ; I '$G(DDSL) D . N I,L,R . S L=1,R=DIC_DA_"," . F I=$L(R,",")-1:-1:1 I $D(^TMP("DDS",$J,"LOCK",$P(R,",",1,I)_")"))#2 S L=0 Q . I L,$D(^TMP("DDS",$J,"LOCK",$P(R,"(")))#2 S L=0 . I L L +@(DIC_+Y_")"):0 S ^TMP("DDS",$J,"LOCK",DIC_+Y_")")="" ; S DDSDA=+Y_"," F I=1:1 Q:$D(DA(I))[0 S DDSDA=DDSDA_DA(I)_"," S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=DDSDA_DIC Q ; REQID(FIL,REQ) ; ;Get list of required identifiers into DDSREQ N F K REQ S F="" F S F=$O(^DD(FIL,0,"ID",F)) Q:F'=+$P(F,"E") D . S:$P($G(^DD(FIL,F,0)),U,2)["R" REQ(F)="" Q $D(REQ)>0 ; DESTROY(PG) ;Destroy all data for page PG N P,B,F,IENS,TP,FIL,FLD S P=$O(^DIST(.403,+DDS,40,"B",PG,"")) Q:'P S B=0 F S B=$O(^DIST(.403,+DDS,40,P,40,B)) Q:'B D . Q:'$D(^DIST(.403,+DDS,40,P,40,B,0)) . Q:'$D(^DIST(.404,B,0)) S FIL=$P(^(0),U,2) . S F=0 F S F=$O(^DIST(.404,B,40,F)) Q:'F D .. Q:'$D(^DIST(.404,B,40,F,0)) S TP=$P(^(0),U,3) .. S:'TP TP=3 .. ; .. I TP=3 S FF="F"_FIL,FLD=$G(^DIST(.404,B,40,F,1)) Q:FLD?."^" .. E I TP=2 S FF="F0",FLD=F_","_B .. E Q .. ; .. S IENS=" " .. F S IENS=$O(@DDSREFT@(FF,IENS)) Q:IENS="" K ^(IENS,FLD) ; K @DDSREFT@(P),@DDSREFT@("XCAP",P) Q ; ; DDSDA(DA,DL,DDSDA) ;Determine DDSDA ; N I I DA="" S DDSDA="" Q S DDSDA=DA_"," F I=1:1:DL S DDSDA=DDSDA_DA(I)_"," Q DDSVAL^INT^1^60300,29510^0 DDSVAL ;SFISC/MKO-GET,PUT FOR DD IELDS ;2OCT2003 ;;22.0;VA FileMan;**1003**;Mar 30, 1999 GET(DDSFILE,DA,DDSFLD,DDSER,DDSPARM) ;Get value for file/field N DDP,DIE,DDSANS,DDSTMP,X N DDSVDA,DDSVDDL0,DDSVDL,DDSVDV,DDSVND,DDSVPC,DIERR ; S DDSANS="" I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"I" ; D GDIE() G:$G(DIERR) GETQ G:'$G(DDSVDA) GETQ ; I DDSFLD[":",$$FIND^DDSLIB(DDSFLD,":") D G GETQ . S DDSANS=$$REL^DDSVALM(DDP,.DA,DDSFLD,DDSPARM) ; S DDSFLD=$$FIELD(DDP,DDSFLD) G:$G(DIERR) GETQ ; S:$D(DDSREFT)#2 DDSTMP=$NA(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD)) I $D(DDS),$D(DDSREFT)#2,$D(@DDSTMP@("D")) D . I $D(@DDSTMP@("M")),'^("M") D Q .. S DDSANS=$NA(^TMP("DDSWP",$J,DDP,DDSVDA,DDSFLD)) .. M @DDSANS=@DDSTMP@("D") . S DDSANS=$G(@DDSTMP@("D")) I DDSPARM["E",$D(^("X"))#2 S DDSANS=^("X") E D . D GNDPC Q:$G(DIERR) . I DDSVPC=0,DDSVDV["W" D GETWP^DDSVALM Q . S DDSANS=$$GVAL(DIE,DA,DDSVND,DDSVPC) . I DDSPARM["E" S DDSANS=$$EXTERNAL^DILFD(DDP,DDSFLD,"",DDSANS) ; GETQ D:$G(DIERR) ERR^DDSVALM("$$GET^DDSVAL") Q DDSANS ; PUT(DDSFILE,DA,DDSFLD,DDSVAL,DDSER,DDSPARM) ;Put value for file/field N DDP,DDSVDA,DDSV0,DDSV02,DDSVDL,DIE N DIERR ; S:$D(DDSVAL)[0 DDSVAL="" I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"E" ; D GDIE($D(DDS)#2) G:$G(DIERR) PUTQ G:'$G(DDSVDA) PUTQ S DDSFLD=$$FIELD(DDP,DDSFLD) G:$G(DIERR) PUTQ I DDSFLD=.01,"@"[DDSVAL D BLD^DIALOG(3086) G PUTQ ; S DDSV0=^DD(DDP,DDSFLD,0),DDSV02=$P(DDSV0,U,2) I +DDSV02 D . D MULT^DDSVALM E D VALPUT ; PUTQ D:$G(DIERR) ERR^DDSVALM("PUT^DDSVAL") Q ; VALPUT ;Validate and put N DDSVY I DDSPARM["E" D . D VAL^DIE(DDP,DDSVDA,DDSFLD,"ER",DDSVAL,.DDSVY) E D . D AUXVAL^DIEV(DDP,DDSVDA,DDSFLD,"EIR",DDSVAL,.DDSVY,DDSV0,DDSV02) Q:$G(DIERR) I DDSVY=DDSVY(0),'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD,"X")) K DDSVY(0) ; I $D(DDS) D . S:'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD)) ^("GL")=DIE . D UPDATE(DDP,DDSVDA,.DA,DDSFLD,DDSPG,.DDSVY) . S DDSCHG=1 E D . N DDSFDA . S DDSFDA(DDP,DDSVDA,DDSFLD)=DDSVY . D FILE^DIE("","DDSFDA") Q ; UPDATE(DDP,DDSVDA,DA,FLD,PG,Y) ;Store value, repaint N DX,DY,BK,DDO,LEN,EXT,PAGE,RJ,REP,VAL S (EXT,@DDSREFT@("F"_DDP,DDSVDA,FLD,"D"))=Y,^("F")=3 S:$D(Y(0))#2 (EXT,^("X"))=Y(0) ; D:FLD=.01 . S PAGE=0 F S PAGE=$O(@DDSREFS@("F"_DDP,FLD,"L",PAGE)) Q:'PAGE D .. S BK=0 F S BK=$O(@DDSREFS@("F"_DDP,FLD,"L",PAGE,BK)) Q:'BK D ... D:$P($G(@DDSREFS@(PAGE,BK)),U,8) .... N DDSPTB S DDSPTB=$G(@DDSREFS@(PAGE,BK,"PTB")) .... D:DDSPTB]"" RPF^DDS7(DDP,DDSPTB,DDSVDA,.DA) ; S BK=0 F S BK=$O(@DDSREFS@("F"_DDP,FLD,"L",PG,BK)) Q:'BK D . S DDO=0 F S DDO=$O(@DDSREFS@("F"_DDP,FLD,"L",PG,BK,DDO)) Q:'DDO D .. S LEN=$G(@DDSREFS@(PG,BK,DDO,"D")) Q:LEN="" .. S DY=+LEN,DX=$P(LEN,U,2),RJ=$P(LEN,U,10),LEN=$P(LEN,U,3) .. S REP=$P($G(@DDSREFS@(PG,BK)),U,7) .. I $G(REP) D Q:DY="" ... N SN,PDA,OFS ... S PDA=$G(@DDSREFT@(PG,BK)) I 'PDA S DY="" Q ... S REP=$P($G(@DDSREFT@(PG,BK,PDA)),U,2,999) I REP="" S DY="" Q ... S SN=$G(@DDSREFT@(PG,BK,PDA,"B",DDSVDA)) I 'SN S DY="" Q HITE ... N HITE S HITE=$$HITE^DDSR(BK),OFS=SN-$P(REP,U,2)*HITE ;DJW/GFT ... I OFS'<0,$P(REP,U,5)*HITE>OFS S DY=DY+OFS ;GFT OFFSET CAN'T BE OUTSIDE SCROLLING WINDOW ... E S DY="" .. S VAL=$P(DDGLVID,DDGLDEL)_$E(EXT,1,LEN)_$P(DDGLVID,DDGLDEL,10) .. X IOXY .. W $S(RJ:$J("",LEN-$L(EXT))_VAL,1:VAL_$J("",LEN-$L(EXT))) ; D:$D(@DDSREFS@("PT",DDP,FLD)) RPB^DDS7(DDP,FLD,PG) D:$D(@DDSREFS@("COMP",DDP,FLD,PG)) RPCF^DDSCOMP(PG) Q ; GDIE(DDSVL) ;In: ; DDSFILE = File # or root ; DA = Record array ; DDSVL = Flag to lock record ;Returns: ; DIE = Global root of file ; DDP = File # ; DDSVDL = Level # ; DDSVDA = DA,DA(1),..., S DDP=$S(DDSFILE=+DDSFILE:DDSFILE,1:+$P($G(@(DDSFILE_"0)")),U,2)) I DDP=0 D BLD^DIALOG(202,"file") Q D GL^DDS10(DDP,.DA,.DIE,.DDSVDL,.DDSVDA,$G(DDSVL)) Q ; GNDPC ;In: ; DDP = File # ; DDSFLD = Field # ;Returns: ; DDSVDDL0 = 0 node of DD ; DDSVND = Node where data resides ; DDSVPC = Piece where data resides ; DDSVDV = Field specifications ; X = Pointed to file root or set of codes I $G(DDSFLD)="" D BLD^DIALOG(202,"field") Q S DDSVDDL0=$G(^DD(DDP,DDSFLD,0)) I DDSVDDL0?."^" D Q . N I,E . S (I("FILE"),E("FILE"))=DDP,I(1)="#"_DDSFLD,E("FIELD")=DDSFLD . D BLD^DIALOG(501,.I,.E) ; S DDSVPC=$P(DDSVDDL0,U,4) S DDSVND=$P(DDSVPC,";"),DDSVPC=$P(DDSVPC,";",2) S DDSVDV=$P(DDSVDDL0,U,2),X=$P(DDSVDDL0,U,3) ; N P S P("FILE")=DDP,P("FIELD")=DDSFLD I DDSVPC=" " D . D BLD^DIALOG(520,"computed",.P) I DDSVPC=0 D . S DDSVDV=+DDSVDV_$P($G(^DD(+DDSVDV,.01,0)),U,2) . D:DDSVDV'["W" BLD^DIALOG(520,"multiple",.P) Q ; GVAL(DIE,DA,ND,PC) ;Get value N LN,Y S LN=$G(@(DIE_"DA,ND)")) I $E(PC)'="E" S Y=$P(LN,U,PC) E S Y=$E(LN,+$E(PC,2,999),$P(PC,",",2)) S:Y?." " Y="" Q Y ; FIELD(DDP,FLD) ;Get field number N F,P S:$E(FLD)="""" FLD=$$UQT^DDSLIB($E(FLD,1,$$AFTQ^DDSLIB(FLD)-1)) ; S F=FLD,P("FILE")=DDP I FLD'=+$P(FLD,"E") D Q:$G(DIERR) "" . S F=$O(^DD(DDP,"B",FLD,"")) . I F="" S P(1)=FLD D BLD^DIALOG(501,.P) ; I $D(^DD(DDP,F,0))[0 S P(1)="#"_F D BLD^DIALOG(501,.P) Q "" Q F DDSVALF^INT^1^60300,29510^0 DDSVALF ;SFISC/MKO-GET,PUT VALUES FOR FORM ONLY FIELDS ;2OCT2003 ;;22.0;VA FileMan;**8,1003**;Mar 30, 1999 GET(DDSVFD,DDSVBK,DDSVPG,DDSPARM,DDSVDA) ;Get value ;In: DDSPG = Current page ; DDSBK = Current block ; DDSPARM = "I" : internal, "E" : external form ; N DDSANS,DDSFLD,DDSVDDP,DIERR I $D(DDSPG)[0 N DDSPG S DDSPG=0 I $D(DDSBK)[0 N DDSBK S DDSBK=0 S DDSANS="" I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"I" ; S DDSFLD=$P($$GETFLD^DDSLIB($G(DDSVFD),$G(DDSVBK),$G(DDSVPG),DDS,$G(DDSPG),$G(DDSBK),"F"),",",1,2) G:$G(DIERR) GETQ ; S DDSVFD=+DDSFLD,DDSVBK=+$P(DDSFLD,",",2) ; S DDSVDDP=+$P($G(^DIST(.404,DDSVBK,0)),U,2) I DDSVDDP,$G(DDSVDA)]"" N DDSDA D . I DDSVDA'["," S DDSVDA=$$IENS^DILF(.DDSVDA) . E S:DDSVDA'?.E1"," DDSVDA=DDSVDA_"," . S DDSDA=DDSVDA E I DDSVDDP,DDSVBK'=DDSBK N DDSDA D GL^DDS10(DDSVDDP,.DDSDAORG,"","",.DDSDA) ; I $D(@DDSREFT@("F0",DDSDA,DDSFLD,"D"))#2 S DDSANS=^("D") S:DDSPARM["E"&($D(^("X"))#2) DDSANS=^("X") G GETQ ; I "013"[$P(^DIST(.404,DDSVBK,40,DDSVFD,0),U,3) D BLD^DIALOG(520,"DD or caption-only") G GETQ ; ;Form-only fields I $P($G(^DIST(.404,DDSVBK,40,DDSVFD,0)),U,3)=2 D G:$G(DIERR) GETQ . I $P($G(^DIST(.404,DDSVBK,40,DDSVFD,20)),U)="" D Q .. N P S P(1)="READ TYPE",P(2)="FIELD multiple of the BLOCK" .. D BLD^DIALOG(3011,.P) . D:$D(^DIST(.404,DDSVBK,40,DDSVFD,3))#2 DEF(^(3),$G(^(3.1)),.DDSANS) . S (@DDSREFT@("F0",DDSDA,DDSFLD,"D"),^("O"))=DDSANS . I DDSANS]"" D .. D:$D(DDSANS(0)) ... S @DDSREFT@("F0",DDSDA,DDSFLD,"X")=$G(DDSANS(0,0),DDSANS(0)) ... S:DDSPARM["E" DDSANS=$G(DDSANS(0,0),DDSANS(0)) .. S $P(@DDSREFT@("F0",DDSDA,DDSFLD,"F"),U)=3,DDSCHG=1 ; ;Computed fields E S:$P($G(^DIST(.404,DDSVBK,40,DDSVFD,0)),U,3)=4 DDSANS=$$VAL^DDSCOMP(DDSVFD,DDSVBK,DDSDA) ; GETQ D:$G(DIERR) ERR^DDSVALM("$$GET^DDSVALF") Q DDSANS ; PUT(DDSVFD,DDSVBK,DDSVPG,DDSVAL,DDSPARM,DDSVDA) ;Put value N DIR,X,Y N DDER,DDSFLD,DDSVDDP,DDSVX,DIERR I $D(DDSPG)[0 N DDSPG S DDSPG=0 I $D(DDSBK)[0 N DDSBK S DDSBK=0 S:$D(DDSVAL)[0 DDSVAL="" I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"E" ; S DDSFLD=$$GETFLD^DDSLIB($G(DDSVFD),$G(DDSVBK),$G(DDSVPG),DDS,DDSPG,DDSBK,"F") G:$G(DIERR) PUTQ S DDSVFD=+DDSFLD,DDSVBK=+$P(DDSFLD,",",2),DDSVPG=$P(DDSFLD,",",3) S DDSFLD=$P(DDSFLD,",",1,2) ; S DDSVDDP=+$P($G(^DIST(.404,DDSVBK,0)),U,2) I DDSVDDP,$G(DDSVDA)]"" N DDSDA D . I DDSVDA'["," S DDSVDA=$$IENS^DILF(.DDSVDA) . E S:DDSVDA'?.E1"," DDSVDA=DDSVDA_"," . S DDSDA=DDSVDA E I DDSVDDP,DDSVBK'=DDSBK N DDSDA D GL^DDS10(DDSVDDP,.DDSDAORG,"","",.DDSDA) ; I $P(^DIST(.404,DDSVBK,40,DDSVFD,0),U,3)'=2 D BLD^DIALOG(520,"DD, computed, or caption-only") G PUTQ ; S DIR(0)=$P(^DIST(.404,DDSVBK,40,DDSVFD,20),U)_$P(^(20),U,2,3) I DDSPARM["I",$E(DIR(0))="P"!(DIR(0)?1"DD".E) D . N FIL,FILROOT,FLD . S Y=DDSVAL . I $E(DIR(0))="P" D .. S FIL=$P($P(DIR(0),U,2),":") .. I 'FIL S FILROOT=U_FIL,FIL=+$P($G(@(U_FIL_"0)")),U,2) Q:'FIL .. E S FILROOT=$G(^DIC(FIL,0,"GL")) Q:FILROOT="" .. S Y(0)=$P($G(@(FILROOT_Y_",0)")),U) .. S Y(0)=$$EXTERNAL^DILFD(FIL,.01,"",Y(0)) . E D .. N DV,I S FIL=$P($P(DIR(0),","),U,2),FLD=$P(DIR(0),",",2) .. S DV=$P($G(^DD(FIL,FLD,0)),U,2) .. F I="O","P","V","D","S" I DV[I S Y(0)=$$EXTERNAL^DILFD(FIL,FLD,"",Y) Q E D G:$G(DDER) PUTQ . I DDSVAL="" D Q .. N DDSVREQ .. S DDSVREQ=$P($G(@DDSREFT@(DDSVPG,DDSVBK,DDSVFD)),U) .. S:DDSVREQ]"" DDSVREQ=$P($G(^DIST(.404,DDSVBK,40,DDSVFD,4)),U) .. I DDSVREQ S DDER=1 .. E S Y="" . S DIR("V")="",(X,DIR("B"))=DDSVAL . S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999) . I $P(DIR(0),U)["P",$P($P(DIR(0),U,2),":",2)'["Z" D .. N I .. S I=$P(DIR(0),U,2) Q:$P(I,":",2)["Z" .. S $P(I,":",2)=$P(I,":",2)_"Z" .. S $P(DIR(0),U,2)=I . D ^DIR . I $E($P(DIR(0),U))="P" S Y=$P(Y,U) ; ;Update ^TMP S DDSCHG=1 S (DDSVX,@DDSREFT@("F0",DDSDA,DDSFLD,"D"))=Y,^("F")=3 S:$D(Y(0))#2 (DDSVX,^("X"))=$S($D(Y(0,0))#2:Y(0,0),1:Y(0)) I $D(^("X"))#2,Y="" S (DDSVX,^("X"))="" ; ;Repaint field if it appears on the current page I $D(@DDSREFS@("F0",DDSFLD,"L",DDSPG,DDSVBK,DDSVFD))#2 D . N DY,DX,DDSVL,DDSVRJ,DDSX,DDSVREP . S DDSVREP=$P($G(@DDSREFS@(DDSPG,DDSVBK)),U,7) . S DY=+@DDSREFS@(DDSPG,DDSVBK,DDSVFD,"D"),DX=$P(^("D"),U,2),DDSVL=$P(^("D"),U,3),DDSVRJ=$P(^("D"),U,10) . I $G(DDSVREP) D Q:DY="" .. N DDSVSN,DDSVPDA,DDSVOFS .. S DDSVPDA=$G(@DDSREFT@(DDSPG,DDSVBK)) I 'DDSVPDA S DY="" Q .. S DDSVREP=$P($G(@DDSREFT@(DDSPG,DDSVBK,DDSVPDA)),U,2,999) I DDSVREP="" S DY="" Q .. S DDSVSN=$G(@DDSREFT@(DDSPG,DDSVBK,DDSVPDA,"B",DDSDA)) I 'DDSVSN S DY="" Q HITE .. N HITE S HITE=$$HITE^DDSR(DDSVBK),DDSVOFS=DDSVSN-$P(DDSVREP,U,2)*HITE ;DJW/GFT .. I DDSVOFS'<0,$P(DDSVREP,U,5)*HITE>DDSVOFS S DY=DY+DDSVOFS ;GFT OFFSET CAN'T BE OUTSIDE SCROLLING WINDOW .. E S DY="" . S DDSX=$P(DDGLVID,DDGLDEL)_$E(DDSVX,1,DDSVL)_$P(DDGLVID,DDGLDEL,10) . X IOXY . W $S(DDSVRJ:$J("",DDSVL-$L(DDSVX))_DDSX,1:DDSX_$J("",DDSVL-$L(DDSVX))) ; D . N DDP,DDSDA S DDP=0,DDSDA="0," . D:$D(@DDSREFS@("PT",DDP,DDSFLD)) RPB^DDS7(DDP,DDSFLD,DDSPG) . D:$D(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG)) RPCF^DDSCOMP(DDSPG) ; PUTQ D:$G(DIERR) ERR^DDSVALM("PUT^DDSVALF") Q ; DEF(DDSLN3,DDSLN31,Y) ;Get default N DDER,DIR,X Q:DDSLN3="" ; I DDSLN3'="!M" S Y=DDSLN3 E I DDSLN31'?."^" X DDSLN31 S:$D(Y)[0 Y="" Q:Y="" ; S DIR(0)=$P(^DIST(.404,DDSVBK,40,DDSVFD,20),U)_$P(^(20),U,2,3) S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999) S DIR("V")="",(X,DIR("B"))=Y D ^DIR I DDER K Y S Y="" ; I Y]"",$E($P(DIR(0),U))="P" S Y=$P(Y,U) Q ; DDSVALM^INT^1^60300,29510^0 DDSVALM ;SFISC/MKO-PUT FOR MULTIPLES (SELECT PROMPT) ;10:45 AM 9 Sep 1994 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; MULT ;Put multiple or wp field N DDSVDIC,DDSVDV,DDSVND,DDSVPC,DDSVSUB S DDSVPC=$P(DDSV0,U,4),DDSVND=$P(DDSVPC,";"),DDSVPC=$P(DDSVPC,";",2) S DDSVSUB=+DDSV02 Q:$D(^DD(DDSVSUB,.01,0))[0 S DDSVDV=DDSVSUB_$P(^DD(DDSVSUB,.01,0),U,2),X=$P(^(0),U,3) S DDSVDIC=DIE_DA_","""_DDSVND_"""," ; I DDSVDV["W" D PUTWP I DDSVDV'["W" D PUTMULT Q ; PUTMULT ;Put for multiples N DDSVRN S DDSVRN=$S(DDSVAL="FIRST":$O(@(DDSVDIC_"0)")),DDSVAL="LAST":$O(@(DDSVDIC_""" "")"),-1),1:+$G(DDSVAL)) ; K Y S Y="",Y(0)="" I DDSVRN>0,$D(@(DDSVDIC_+DDSVRN_",0)"))#2 S Y(0)=$P(^(0),U) D . I DDSVDV["O"!(DDSVDV["P")!(DDSVDV["V")!(DDSVDV["D")!(DDSVDV["S") D .. S Y(0)=$$EXTERNAL^DILFD(DDSVSUB,.01,"",DDSVRN) . S Y=DDSVRN ; S:'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD,"M")) ^("M")=1_DDSVDIC_U_DDSVSUB D UPDATE^DDSVAL(DDP,DDSVDA,.DA,DDSFLD,DDSPG,.Y) Q ; PUTWP ;File wp field from @DDSVAL into @DDSREFT N DDSTMP S DDSTMP=$NA(@DDSREFT@("F"_DDP,DDSDA)) ; I DDSVAL]"",$D(@DDSVAL) D Q:$G(DIERR) . D PUTWP^DIEFW($E("A",DDSPARM["A"),DDSVAL,$NA(@DDSTMP@(DDSFLD,"D"))) E K @DDSTMP@(DDSFLD,"D") ; S:$D(@DDSTMP@(DDSFLD,"M"))[0 ^("M")="0"_DDSVDIC_U_DDSVSUB S:$D(@DDSTMP@("GL"))[0 ^("GL")=DIE S (DDSCHG,@DDSTMP@(DDSFLD,"F"))=3 Q ; GETWP ;Merge wp field into ^TMP, return root in DDSANS N DDSGL S DDSGL=DIE_DA_","""_DDSVND_"""," S DDSANS=$NA(^TMP("DDSWP",$J,DDP,DDSDA,DDSFLD)) ; K @DDSANS M:$D(@(DDSGL_"0)"))#2 @DDSANS=@($E(DDSGL,1,$L(DDSGL)-1)_")") Q ; REL(DDP,DA,DDSFLD,DDSPARM) ;Relational syntax N DDSCD,DDSI,X D DD^DDSPTR(DDP,DDSFLD,"",.DDSCD,"",DDSPARM["I"+1) F DDSI=1:1:DDSCD X DDSCD(DDSI) Q X ; ERR(DDSVEP) ;Print error messages Q:'$G(DIERR) I '$D(DDS) D MSG^DIALOG("BW") Q N DDSVMSG S DDSER=DIERR D BLD^DIALOG(3031,DDSVEP,"","DDSVMSG") D MSG^DDSMSG(DDSVMSG(1)),ERR^DDSMSG Q DDSWP^INT^1^60335,48316^0 DDSWP ;SFISC/MKO-WP ;21AUG2005 ;;22.0;VA FileMan;**999,1004,1021**;Mar 30, 1999 EDIT ;Edit the word processing field N I S DDSUE=$D(DDSTP)#2!$S($P($G(DDSU("A")),U,4)="":$P($G(DDSO(4)),U,4),1:$P(DDSU("A"),U,4)) I 'DDSUE S I=$P((DDSU("DD")),U,2) I I,$P($G(^DD(I,.01,0)),U,2)["I",$G(DDSGL)["(",$O(@(DDSGL_"0)")) S DDSUE=1 ;UNEDITABLE WORD-PROCESSING FIELD I DDSUE D I $D(DIRUT) K DIRUT,DUOUT,DIROUT G EDITQ .D:DDM CLRMSG^DDS .N DDSWP D BLD^DIALOG(8178,,,"DDSWP"),MSG^DDSMSG(.DDSWP) H 2 Q ;** S DDSUTL=$NA(@DDSREFT@("F"_DDP,DDSDA,DDSFLD)) ; I $D(@DDSUTL@("F"))[0,$D(@(DDSGL_"0)"))#2 D . K @DDSUTL@("D") . M @DDSUTL@("D")=@($E(DDSGL,1,$L(DDSGL)-1)_")") MOUSEOFF W *27,"[?1000l" S (DY,DX)=0 X IOXY W $P(DDGLCLR,DDGLDEL,2) S DIC=$E(DDSUTL,1,$L(DDSUTL)-1)_",""D"",",DWPK=1 S DIWESUB=$P($G(DDSU("DD")),U) K:DIWESUB="" DIWESUB ;S DDWFLAGS=$G(DDWFLAGS)_"K" D EN^DIWE ;,INIT^DDGLIB0() K DIC,DIWESUB,DWPK I 'DDSUE S DDSCHG=1,@DDSUTL@("F")=1 E K @DDSUTL@("D") MOUSEON I $G(DDS)>0,$G(DDSMOUSY) W *27,"[?1000h" EDITQ K DDSUE,DDSUTL Q ; WP ;At the wp field S DIR(0)="FO^0:0" EGP S DIR("?")="^W $$EZBLD^DIALOG(8179)" ;**CCO/NI "Press to edit this word processing field." S DIR("??")="^D HELP^DDSWP" D ^DIR K DIR,DUOUT,DIRUT,DIROUT Q HELP ;?? help at the WP field S DDSFN=+$P(DDSU("M"),U,3) D:$G(^DD(DDSFN,.01,3))]"" MSG^DDSMSG($$HELP^DIALOGZ(DDSFN,.01)) ;**CCO/NI WORD-PROCESSING FIELD HELP X:$G(^DD(DDSFN,.01,4))]"" ^(4) D:$D(^DD(DDSFN,.01,21)) WP^DDSMSG("^DD("_DDSFN_",.01,21)") K DDSFN Q DDSZ^INT^1^60300,29510^0 DDSZ ;SFISC/MKO-FORM COMPILER ;17JUN2004 ;;22.0;VA FileMan;**94,1003,1004**;Mar 30, 1999 ; ;Prompt, compile N DDSFRM,DDSDDP,DDSREFS N C,DIC,X,Y I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU ; S DIC="^DIST(.403,",DIC(0)="AEQZ" D ^DIC K DIC Q:Y=-1!'$D(^DIST(.403,+Y,0)) S DDSFRM=Y,DDSDDP=$P(Y(0),U,8) ; W !!,"Compiling "_$P(Y,U,2)_" (#"_+Y_") ...",! D EN(DDSFRM,DDSDDP) I $G(DIERR) W $C(7) D MSG^DIALOG("BW") Q ; ALL ;Compile all forms N DDSFRM,DDSDDP,DDSFNUM,DDSREFS I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU W:'$D(DDSQUIET) !,"Compiling all forms ...",! ; S DDSFNUM=0 F S DDSFNUM=$O(^DIST(.403,DDSFNUM)) Q:'DDSFNUM D . Q:$D(^DIST(.403,DDSFNUM,0))[0 . S DDSFRM=DDSFNUM_U_$P(^DIST(.403,DDSFNUM,0),U),DDSDDP=+$P(^(0),U,8) . S DDSREFS=$$REF^DDS0(DDSFRM) . W:'$D(DDSQUIET) !?3,$P(DDSFRM,U,2),?35,"(#"_+DDSFRM_")" . D EN(DDSFRM,DDSDDP) . I $G(DIERR),'$D(DDSQUIET) W !,$C(7) D MSG^DIALOG("BW") W ! Q ; EN(DDSFRM,DDSDDP,DDSREFS) ;Compile a form N DDSDO,DDSPG,DDSNDD,DDSPGRP ; S:'$G(DDSDDP) DDSDDP=$P(^DIST(.403,+DDSFRM,0),U,8) S:$G(DDSREFS)="" DDSREFS=$$REF^DDS0(DDSFRM) K @DDSREFS ; ;Find page groups D PGRP^DDSZ3(+DDSFRM,.DDSPGRP) ; S DDSPG=0,(DDSDO,DDSNDD)=1 F S DDSPG=$O(^DIST(.403,+DDSFRM,40,DDSPG)) Q:'DDSPG D PG(DDSFRM,DDSPG,DDSDDP,.DDSDO,.DDSNDD) Q:$G(DIERR) I $G(DIERR) D ERR(DDSFRM,DDSREFS) Q S $P(^DIST(.403,+DDSFRM,0),U,9,11)=+$G(DDSDO)_U_+$G(DDSNDD)_U_1 ;DDSNDD=1 means don't need a starting DA Q ; PG(DDSFRM,DDSPG,DDSDDP,DDSDO,DDSNDD) ;Compile a page ; Q:$D(^DIST(.403,+DDSFRM,40,DDSPG,0))[0 D:$P($G(^DIST(.403,+DDSFRM,40,DDSPG,1)),U,2)]"" ASUB^DDSZ3(DDSPG,DDSFRM) ; ;Get page coordinates S DDSPX=$P(^DIST(.403,+DDSFRM,40,DDSPG,0),U,3) S DDSPY=$P(DDSPX,",")-1,DDSPX=$P(DDSPX,",",2)-1 S:DDSPY<0 DDSPY=0 S:DDSPX<0 DDSPX=0 ; ;Compile header block S DDSB=$P($G(^DIST(.403,+DDSFRM,40,DDSPG,0)),U,2) I DDSB]"" D BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,"",1,"",.DDSNDD,.DDSSCR,.DDSNAV,.DDSORD) G:$G(DIERR) END ; ;Compile all other blocks on page S DDSBO="" F S DDSBO=$O(^DIST(.403,+DDSFRM,40,DDSPG,40,"AC",DDSBO)) Q:DDSBO="" S DDSB=$O(^(DDSBO,0)) Q:'DDSB D BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,DDSBO,"",.DDSDO,.DDSNDD,.DDSSCR,.DDSNAV,.DDSORD) G:$G(DIERR) END ; D:$D(DDSSCR)!$D(DDSORD) EN^DDSZ2(.DDSSCR,.DDSNAV,.DDSORD,.DDSRNAV) ; END K DDSB,DDSBO,DDSMUL,DDSNAV,DDSORD K DDSP,DDSPX,DDSPY,DDSREP,DDSRNAV,DDSSCR Q ; BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,DDSBO,DDSH,DDSDO,DDSNDD,DDSSCR,DDSNAV,DDSORD) ; ;Compile block ; DDSH = 1 if header block ; DDSDO = killed if any edit blocks ; DDSNDD = killed if any DD fields ; N DDP I $D(^DIST(.404,DDSB,0))[0 D BLD^DIALOG(3051,"#"_DDSB) Q S DDSDN=$P(^DIST(.404,DDSB,0),U,3),DDP=+$P(^(0),U,2) ; S DDSPTB="" S:'$G(DDSH) DDSPTB=$G(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,1)) ; ;Get DDSBY,DDSBX,DDSTP I $G(DDSH) S DDSBY=DDSPY,DDSBX=DDSPX,DDSTP="h",DDSREP=1 E D . S DDSBX=$P(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,0),U,3),DDSTP=$P(^(0),U,4) S DDSREP=$S($G(^(2)):^(2),1:1) . K:DDSTP="e" DDSDO . S DDSBY=$P(DDSBX,",")-1,DDSBX=$P(DDSBX,",",2)-1 . S:DDSBY<0 DDSBY=0 S:DDSBX<0 DDSBX=0 . S DDSBY=DDSBY+DDSPY,DDSBX=DDSBX+DDSPX IND . I DDSREP>1,+$G(^DIST(.403,+DDSFRM,21))=+$P($G(^DIST(.403,+DDSFRM,40,DDSPG,0)),U) D ;RECORD SELECTION PAGE USING REPEATING BLOCK ..N IND ..S IND=$P(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,2),U,2) I IND]"",$D(^DD(+DDSDDP,0,"IX",IND,+DDSDDP)) D ...S IND=^DIC(+DDSDDP,0,"GL")_""""_IND_"""" ;BUILD COMPUTED MULTIPLE OFF THE REPEATING-BLOCK INDEX ...I $D(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,"COMP MUL")) ...S ^("COMP MUL")="N D,DIMQ,DIMSTRT,DIMSCNT S (DIMQ,DIMSTRT)=$NA("_IND_")),DIMSCNT=$QL(DIMQ) F S DIMQ=$Q(@DIMQ) Q:DIMQ="""" Q:$NA(@DIMQ,DIMSCNT)'=DIMSTRT S D=$QS(DIMQ,$QL(DIMQ)) Q:'D I @DIMQ="""" N D0 S D0=D X DICMX" ..I $G(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,"COMP MUL"))]"" S ^("COMP MUL PTR")=+DDSDDP ; ;Set @DDSREFS@(DDSPG,DDSB) S @DDSREFS@(DDSPG,DDSB)=DDSBY_U_DDSBX_U_$P($G(^DIST(.404,DDSB,0)),U,2)_U_DDSDN_U_DDSTP_$S(DDSREP>1:U_U_+DDSREP,1:"") ; D:DDSPTB]"" PT^DDSPTR(DDSDDP,DDSPTB,DDSFRM,DDSPG,DDSB) D EN^DDSZ1(DDSPG,DDSB,DDP,DDSBY,DDSBX,DDSBO,DDSTP,DDSREP,.DDSNDD,.DDSPGRP,.DDSSCR,.DDSNAV,.DDSORD,.DDSRNAV) ; K DDSBX,DDSBY,DDSDN,DDSPTB,DDSTP Q ; ENGRP(DDSFRM) ;Compile a form and all forms that use any of the blocks ;on that form N DDSLST D FRMLST(DDSFRM,.DDSLST) ; ;Compile all forms in DDSLST S DDSFRM=0 F S DDSFRM=$O(DDSLST(DDSFRM)) Q:'DDSFRM D EN(DDSFRM) Q ; DELGRP(DDSFRM) ;Uncompile a form and all forms that use any of the blocks ;on that form N DDSLST D FRMLST(DDSFRM,.DDSLST) ; ;Uncompile all forms in DDSLST S DDSFRM=0 F S DDSFRM=$O(DDSLST(DDSFRM)) Q:'DDSFRM D DEL(DDSFRM) Q ; ENLIST(DDSROOT) ;Compile all forms in @DDSROOT N DDSFRM S DDSFRM=0 F S DDSFRM=$O(@DDSROOT@(DDSFRM)) Q:'DDSFRM D EN(DDSFRM) Q ; FRMLST(DDSFRM,DDSLST) ;Build list of forms that contain blocks on this form N DDSPG,DDSBK S DDSPG=0 F S DDSPG=$O(^DIST(.403,DDSFRM,40,DDSPG)) Q:'DDSPG D . D BLDLST($P($G(^DIST(.403,DDSFRM,40,DDSPG,0)),U,2),.DDSLST) . S DDSBK=0 F S DDSBK=$O(^DIST(.403,DDSFRM,40,DDSPG,40,DDSBK)) Q:'DDSBK D .. D BLDLST($P($G(^DIST(.403,DDSFRM,40,DDSPG,40,DDSBK,0)),U),.DDSLST) Q ; BLDLST(DDSBK,DDSLST) ;Build list of forms that contain a given block N DDSFRM Q:'$G(DDSBK) S DDSFRM=0 F S DDSFRM=$O(^DIST(.403,"AB",DDSBK,DDSFRM)) Q:'DDSFRM S DDSLST(DDSFRM)="" S DDSFRM=0 F S DDSFRM=$O(^DIST(.403,"AC",DDSBK,DDSFRM)) Q:'DDSFRM S DDSLST(DDSFRM)="" Q ; DELALL ;Delete compile global for all forms N DDSFRM,DDSFNUM,DDSREFS W:'$D(DDSQUIET) !,"Deleting compiled form data ...",! ; S DDSFNUM=0 F S DDSFNUM=$O(^DIST(.403,DDSFNUM)) Q:'DDSFNUM D . Q:$D(^DIST(.403,DDSFNUM,0))[0 . S DDSFRM=DDSFNUM_U_$P(^DIST(.403,DDSFNUM,0),U) . W:'$D(DDSQUIET) !?3,$P(DDSFRM,U,2),?35,"(#"_+DDSFRM_")" . D DEL(DDSFRM) Q ; DEL(DDSFRM) ;Delete compiled global N DDSREFS S DDSREFS=$$REF^DDS0(DDSFRM) K @DDSREFS S $P(^DIST(.403,+DDSFRM,0),U,11)="" Q ; ERR(DDSFRM,DDSREFS) ;Print error, kill compiled global Q:'$G(DIERR) N DDSNAM S DDSNAM=$P(DDSFRM,U,2) S:DDSNAM="" DDSNAM=$P($G(^DIST(.403,+DDSFRM,0)),U) D BLD^DIALOG(3002,DDSNAM) S $P(^DIST(.403,+DDSFRM,0),U,11)="" K @DDSREFS Q DDSZ1^INT^1^60300,29510^0 DDSZ1 ;SFISC/MKO-GET BLOCK INFO,SCREEN IMAGE ;20JAN2004 ;;22.0;VA FileMan;**999,1003,1004**;Mar 30, 1999 EN(DDSPG,DDSBK,DDP,DDSBY,DDSBX,DDSBO,DDSTP,DDSREP,DDSNDD,DDSPGRP,DDSSCR,DDSNAV,DDSORD,DDSRNAV) ; ;Input: ; DDSREFS = Global ref ;Output: ; DDSSCR ; DDSNAV ; DDSORD ; DDSRNAV ; N Y S:$G(DDSTP)="" DDSTP="e" I DDSTP'="h",$G(DDSBO),$D(DDSORD(DDSBO))[0 D . S DDSORD(DDSBO)=DDSBK . S:$G(DDSREP)>1 $P(DDSORD(DDSBO),U,2)=$S($P(DDSREP,U,5)]"":$P($$GETFLD^DDSLIB($P(DDSREP,U,5),"","","","",DDSBK),","),1:"FIRST") ; LOOP N DDSHITE S DDSHITE=$$HITE^DDSR(DDSBK),DDSF=0 ;DJW/GFT HEIGHT OF MULTIPLES F S DDSF=$O(^DIST(.404,DDSBK,40,DDSF)) Q:DDSF'=+DDSF D FLD ; KILL K DDSC1,DDSC2,DDSCAP,DDSCLN,DDSD1,DDSD2,DDSD3 K DDSDDL0,DDSF,DDSFLD,DDSKEY,DDSL0,DDSL01,DDSL2,DDSL4,DDSN Q ; FLD ;Set up ; @DDSREFS@(pg,bk,ddo, ; "D") = data $Y^data $X^data $L^field# ; ^xcap $Y^xcap $X^xcap colon^xcap req ; ^1 if computed field^1 if right justified ; "COMPE") = M code that sets X ; "COMPE",1) = array sets DDSE(n) ; ; @DDSREFS@("Ffile#",field#,"L",pg,bk,ddo)="" ; ; DDSSCR(row) = captions on that row ; DDSSCR(row,col) = final columns underlined ; DDSNAV(row,col) = ddo,bk for editable fields ; DDSORD(bo,fo) = ddo for editable fields ; ;Get field properties S:'$P(^DIST(.404,DDSBK,40,DDSF,0),U,3) $P(^(0),U,3)=3 S DDSL0=$G(^DIST(.404,DDSBK,40,DDSF,0)),DDSL01=$G(^(.1)),DDSFLD=$S($P(DDSL0,U,3)=2:DDSF_","_DDSBK,1:+$G(^(1))),DDSL2=$G(^(2)),DDSL4=$G(^(4)) K:$P(DDSL0,U,3)=3!'$P(DDSL0,U,3) DDSNDD ;REMEMBER THAT AT LEAST ONE FIELD IS A DATA DICTIONARY S DDSDDL0=$G(^DD(DDP,DDSFLD,0)) Q:DDSL0?."^"!(DDSL2?."^") S DDSKEY=DDSFLD'[","&($D(^DD("KEY","F",DDP,DDSFLD))>1) S DDSD1=$P($P(DDSL2,U),",")+DDSBY-1 S DDSD2=$P($P(DDSL2,U),",",2)+DDSBX-1 S DDSD3=$P(DDSL2,U,2) S DDSC1=$P($P(DDSL2,U,3),",")+DDSBY-1 S DDSC2=$P($P(DDSL2,U,3),",",2)+DDSBX-1 S DDSCAP=$TR($P(DDSL0,U,2)," ",$C(0)) S DDSCLN=$S(DDSCAP="":"",$P(DDSL0,U,3)=1:"",$P(DDSL2,U,4):"",1:":") ; I DDSC1'<0,DDSC2'<0,$L(DDSCAP)>0,DDSCAP'="!M" D . ;Set CAP xref for ^-jumping . I DDSTP="e","^2^3^"[(U_$P(DDSL0,U,3)_U)!'$P(DDSL0,U,3) D .. N C,I,L .. S I=0 F S I=$O(DDSPGRP(I)) Q:'I Q:U_DDSPGRP(I)_U[(U_DDSPG_U) .. Q:'I .. S C=$P(DDSL0,U,2) .. S:C?1"Select ".E C=$P(C,"Select ",2,999) UP .. S C=$E($$UP^DILIBF(C),1,40) .. S L=$L(DDSREFS)+$L(C)+$L(DDSPGRP(I))+$L(DDSPG)+$L(DDSBK)+$L(DDSF)+30 .. S:L>127 C=$E(C,1,$L(C)-(L-127)) .. S:C]"" @DDSREFS@("CAP",C,DDSPGRP(I),DDSPG,DDSBK,DDSF)="" . ; . ;Set DDSSCR . I DDSC1'<0,DDSC2'<0,$L(DDSCAP)>0,DDSCAP'="!M" D .. N DDSI,DDSX .. S DDSX=DDSCAP_DDSCLN .. F DDSI=1:1:+DDSREP D CAPS ... S $E(DDSSCR(DDSI-1*DDSHITE+1+DDSC1),DDSC2+1,DDSC2+$L(DDSX))=DDSX ;GFT ... S:$S($P(DDSL4,U)]"":+DDSL4,1:$P(DDSDDL0,U,2)["R")!DDSKEY DDSSCR(DDSI-1*DDSHITE+1+DDSC1,DDSC2+1)=DDSC2+$L(DDSCAP) ; ;Set "D", "L" nodes, DDSNAV, and DDSORD I DDSD1'<0,DDSD2'<0,DDSD3>0 D . S @DDSREFS@(DDSPG,DDSBK,DDSF,"D")=DDSD1_U_DDSD2_U_DDSD3_U_DDSFLD . S @DDSREFS@("F"_$S(DDSFLD[",":0,1:DDP),DDSFLD,"L",DDSPG,DDSBK,DDSF)="" I DDSCAP="!M",DDSC1'<0,DDSC2'<0 S $P(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,5,8)=DDSC1_U_DDSC2_U_DDSCLN_U_($P(DDSDDL0,U,2)["R"!+DDSL4!DDSKEY) S:$P(DDSL4,U,3) $P(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,10)=1 ; ;Computed fields I $P(DDSL0,U,3)=4 D K DDSCOMP,DDSAR,DDSEXP,DDSFD Q . S DDSCOMP=$G(^DIST(.404,DDSBK,40,DDSF,30)) Q:DDSCOMP?."^" . D PARSE^DDSCOMP(DDP,DDSCOMP,DDSBK,.DDSEXP,.DDSAR,.DDSFD) . Q:DDSEXP=""!$G(DIERR) . S @DDSREFS@("COMPE",DDSBK,DDSF)=DDSEXP . F DDSAR=1:1:DDSAR D .. S:DDSAR(DDSAR)["*DDSREFC*" DDSAR(DDSAR)=$P(DDSAR(DDSAR),"*DDSREFC*")_$E(DDSREFS,1,$L(DDSREFS)-1)_",""COMPE"","_DDSBK_","_DDSF_","_DDSAR_$P(DDSAR(DDSAR),"*DDSREFC*",2,999) .. S @DDSREFS@("COMPE",DDSBK,DDSF,DDSAR)=DDSAR(DDSAR) .. I $D(DDSAR(DDSAR))>9 N I F I=1:1 Q:$D(DDSAR(DDSAR,I))[0 D ... S @DDSREFS@("COMPE",DDSBK,DDSF,DDSAR,I)=DDSAR(DDSAR,I) . S $P(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,9)=1 . I $G(DDSFD)]"" F DDSAR=1:1:$L(DDSFD,U) D .. N F S F=$P(DDSFD,U,DDSAR) Q:F="" .. S @DDSREFS@("COMP",$P(F,","),$P($P(F,",",2,99),";"),DDSPG,DDSBK,DDSF)="" ; Q:DDSD1<0!(DDSD2<0)!(DDSD3'>0)!(DDSL2?."^") Q:$P(DDSDDL0,U,4)=" ; " Q:DDSTP="h" Q:DDSFLD=.001 I '$P(DDSDDL0,U,2),DDSTP'="e" Q ; S DDSORD(DDSBO,+DDSL0)=DDSF S DDSNAV(DDSD1,DDSD2)=DDSF_","_DDSBK S:$P(DDSDDL0,U,2) DDSMUL(DDSBK,DDSF)="" ; I $G(DDSREP)>1 D . S $P(DDSNAV(DDSD1,DDSD2),",",3)=DDSBO . S DDSRNAV(DDSBO,DDSD1)=DDSBK . S DDSRNAV(DDSBO,DDSD1,DDSD2)=DDSF HITE . S DDSRNAV(DDSBO,DDSD1-.4,DDSD2)=DDSF_",-1" ;DJW/GFT?? . S DDSRNAV(DDSBO,DDSD1+.4,DDSD2)=DDSF_",+1" Q DDSZ2^INT^1^60300,29510^0 DDSZ2 ;SFISC/MKO-LOAD SCR, NAV, AND ORDER INFO ;21JAN2004 ;;22.0;VA FileMan;**8,1003,1004**;Mar 30, 1999 EN(SC,N,O,RNAV) ; ;Input: ; DDSPG ; DDSREFS ; D SCR(.SC),NAV(.N,.RNAV),ORD(.O) D:$D(RNAV) RNAV(.RNAV,.O) Q ; SCR(SC) ;Move image from SC to global N C,P,R,S Q:'$D(SC) S R=0 F S R=$O(SC(R)) Q:'R D . F C=1:1 Q:$E(SC(R),C)'=" " . S @DDSREFS@("X",DDSPG,R-1,C-1)=$TR($E(SC(R),C,999),$C(0)," ") . I $D(SC(R))=11 D .. S S="",P=0 .. F S P=$O(SC(R,P)) Q:'P S S=S_(P-C+1)_";"_(SC(R,P)-C+1)_";U"_U .. S:S?.E1"^" S=$E(S,1,$L(S)-1) .. S:S]"" @DDSREFS@("X",DDSPG,R-1,C-1,"A")=S Q ; NAV(N,RNAV) ; N B,D1,D2,F,LN S N(9999,1)="0,0" ; S D1="" F S D1=$O(N(D1)) Q:D1="" D . S D2="" F S D2=$O(N(D1,D2)) Q:D2="" D .. S F=$P(N(D1,D2),","),B=$P(N(D1,D2),",",2),LN="" .. D NAV1(.N,.RNAV,D1,D2,.LN) .. S @DDSREFS@(DDSPG,B,F,"N")=LN .. S:$D(DDSMUL(B,F)) $P(@DDSREFS@(DDSPG,B,F,"N"),U,11)=1 Q ; NAV1(N,RNAV,D1,D2,LN) ;Setup "N" for navigation N E1,E2,I ; S E1=$S($O(N(D1),-1)]"":$O(N(D1),-1),1:$O(N(""),-1)) S E2=D2 I $D(N(E1,E2))[0 S E2=$S($O(N(E1,E2),-1)]"":$O(N(E1,E2),-1),1:$O(N(E1,E2))) I E1]"",E2]"" D . N RBO . S RBO=$P(N(E1,E2),",",3) . I RBO,$D(RNAV(RBO,E1))#2 D Q:E2="" .. S E2="" F S E2=$O(RNAV(RBO,E1,E2)) Q:E2="" Q:RNAV(RBO,E1,E2)'["," . S $P(LN,U)=$P(N(E1,E2),",",1,2) ; S E1=$S($O(N(D1))]"":$O(N(D1)),1:$O(N(""))) S E2=D2 I $D(N(E1,E2))[0 S E2=$S($O(N(E1,E2),-1)]"":$O(N(E1,E2),-1),1:$O(N(E1,E2))) I E1]"",E2]"" D . N RBO . S RBO=$P(N(E1,E2),",",3) . I RBO,$D(RNAV(RBO,E1))#2 D Q:E2="" .. S E2="" F S E2=$O(RNAV(RBO,E1,E2)) Q:E2="" Q:RNAV(RBO,E1,E2)'["," . S $P(LN,U,2)=$P(N(E1,E2),",",1,2) ; S E1=D1,E2=$O(N(D1,D2)) I E2="" S E1=$S($O(N(E1))]"":$O(N(E1)),1:$O(N(""))),E2=$O(N(E1,"")) I E1]"",E2]"" S $P(LN,U,3)=$P(N(E1,E2),",",1,2) ; S E1=D1,E2=$S($O(N(E1,D2),-1)]"":$O(N(E1,D2),-1),1:"") I E2="" S E1=$S($O(N(E1),-1)]"":$O(N(E1),-1),1:$O(N(""),-1)),E2=$S($O(N(E1,""),-1)]"":$O(N(E1,""),-1),1:"") I E1]"",E2]"" S $P(LN,U,4)=$P(N(E1,E2),",",1,2) ; F I=1:1:4 S:$P($P(LN,U,I),",",2)=B!'$P($P(LN,U,I),",",2) $P(LN,U,I)=+$P(LN,U,I) Q ; ORD(O) ;Setup field order info N B,BO,BP,F,FO,FP S (BO,FO)="" F S BO=$O(O(BO)) Q:BO="" S FO=$O(O(BO,"")) Q:FO]"" S:FO="" BO=$O(O("")) S B=+$G(O(+BO)),F=+$G(O(+BO,+FO)) S @DDSREFS@(DDSPG,"FIRST")=F_","_B ; S (BP,FP)=0 S BO="" F S BO=$O(O(BO)) Q:BO="" D . S B=+O(BO),F=0 . S FO=$O(O(BO,"")) S:FO]"" F=O(BO,FO) . S $P(@DDSREFS@(DDSPG,B),U,9)=F . S:$P(O(BO),U,2)]"" $P(@DDSREFS@(DDSPG,B),U,10)=$S($P(O(BO),U,2)="FIRST":F,1:$P(O(BO),U,2)) . S FO="" F S FO=$O(O(BO,FO)) Q:FO="" D .. S F=O(BO,FO) .. S $P(@DDSREFS@(DDSPG,BP,FP,"N"),U,5)=F_$S(B'=BP:","_B,1:"") .. S FP=F,BP=B S $P(@DDSREFS@(DDSPG,BP,FP,"N"),U,5)=0 Q ; RNAV(DDSRNAV,DDSO) ;Setup nav and fo info for rep blocks N DDSBO,DDSN,B,D1,D2,DN,F,F1,FO,LN,NX,RT S DDSBO="" F S DDSBO=$O(DDSRNAV(DDSBO)) Q:DDSBO="" D . K DDSN M DDSN=DDSRNAV(DDSBO) . S D1="" F S D1=$O(DDSN(D1)) Q:D1="" D:$D(DDSN(D1))#2 .. S B=DDSN(D1) .. N HITE S HITE=$$HITE^DDSR(B) .. S D2="" F S D2=$O(DDSN(D1,D2)) Q:D2="" D ... S F=DDSN(D1,D2),LN="" Q:F["," ... D NAV1(.DDSN,.DDSRNAV,D1,D2,.LN) ... S $P(@DDSREFS@(DDSPG,B,F,"N"),U,6,9)=LN ... Q:HITE<2 ;GFT FIRST ...S FO=$O(DDSO(DDSBO,"")) S:FO FO=DDSO(DDSBO,FO) ...S F1=$O(DDSO(DDSBO,""),-1) S:F1 F1=DDSO(DDSBO,F1) ... I $P(@DDSREFS@(DDSPG,B,F,"N"),U,9)["-" S $P(^("N"),U,9)=$P(^("N"),U,4) I $P(^("N"),U,4)[","!'$P(^("N"),U,4) S $P(^("N"),U,9)=F1_",-1" ;WHERE 'F4' GOES ... I $P(^("N"),U,8)["+" S $P(^("N"),U,8)=$P(^("N"),U,3) I '$P(^("N"),U,3) S $P(^("N"),U,8)=FO_",+1" ;WHERE 'TAB' GOES . S B=+$G(DDSO(+DDSBO)) Q:'B . S FO=$O(DDSO(DDSBO,"")) Q:FO="" . S (F,F1)=DDSO(DDSBO,FO) . F S FO=$O(DDSO(DDSBO,FO)) Q:FO="" D .. S $P(@DDSREFS@(DDSPG,B,F,"N"),U,10)=DDSO(DDSBO,FO) .. S F=DDSO(DDSBO,FO) . S $P(@DDSREFS@(DDSPG,B,F,"N"),U,10)=F1_",+1" . ; . S DN=0 . S F=0 F S F=$O(@DDSREFS@(DDSPG,B,F)) Q:DN=2!(F="") D .. S LN=$G(@DDSREFS@(DDSPG,B,F,"N")) Q:LN="" .. S RT=$P(LN,U,3),NX=$P(LN,U,5) .. S:RT[","!'RT DN=DN+1 .. S:NX[","!'NX DN=DN+1 . ; . S F=0 F S F=$O(@DDSREFS@(DDSPG,B,F)) Q:F="" D .. S $P(@DDSREFS@(DDSPG,B,F,"N"),U,3)=RT .. S $P(@DDSREFS@(DDSPG,B,F,"N"),U,5)=NX Q DDSZ3^INT^1^60300,29510^0 DDSZ3 ;SFISC/MKO-FORM COMPILER ;02:49 PM 30 Dec 1993 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; ASUB(DDSPG,DDSFRM) ; ;Set @DDSREFS@("ASUB",pg,bk,ddo)=subpage for parent field N MF,MB,MP S MF=$P(^DIST(.403,+DDSFRM,40,DDSPG,1),U,2) Q:MF="" S MP=$P(MF,",",3),MB=$P(MF,",",2),MF=$P(MF,",") ; S MF=$$GETFLD^DDSLIB(MF,MB,MP,DDSFRM) I $G(DIERR) K DIERR,^TMP("DIERR",$J) Q S @DDSREFS@("ASUB",$P(MF,",",3),$P(MF,",",2),$P(MF,","))=DDSPG Q ; PGRP(FRM,G) ;Find page groups ;In: FRM = Form number ;Out: G = Array of page groups ; N B,I,NP,P,PP,PG S G=0 S P=0 F S P=$O(^DIST(.403,FRM,40,P)) Q:'P D . Q:'$D(^DIST(.403,FRM,40,P,0)) S NP=$P(^(0),U,4),PP=$P(^(0),U,5) . F PG="NP","PP" I @PG D .. S @PG=$O(^DIST(.403,FRM,40,"B",@PG,"")) Q:'@PG .. S:$D(^DIST(.403,FRM,40,@PG,0))[0 @PG="" . S:NP=P NP=0 S:PP=NP!(PP=P) PP=0 . S I=0 F S I=$O(G(I)) Q:'I Q:U_G(I)_U[(U_P_U) . I 'I S G=G+1,G(G)=P_$S(NP:U_NP,1:"")_$S(PP:U_PP,1:"") Q . F PG="NP","PP" I @PG,U_G(I)_U'[(U_@PG_U) S G(I)=G(I)_U_@PG Q DDU^INT^1^60300,29510^0 DDU ;SFISC/DCM-DD UTILITES ;3/24/91 12:22 PM ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. 0 S DIC="^DOPT(""DDU""," G OPT:$D(^DOPT("DDU",3)) S ^(0)="DATA DICTIONARY UTILITY OPTION^1.01" K ^("B") F X=1:1:3 S ^DOPT("DDU",X,0)=$P($T(@X),";;",2) S DIK=DIC D IXALL^DIK OPT ; S DIC(0)="AEQIZ" D ^DIC G Q:Y<0 S DI=+Y D EN G 0 ; EN ; D @DI W !! Q K %,DIC,DIK,DI,DA,I,J,X,Y Q ; 1 ;;LIST FILE ATTRIBUTES G ^DID ; 2 ;;MAP POINTER RELATIONS G ^DDMAP ; 3 ;;CHECK/FIX DD STRUCTURE G ^DDUCHK ; DDUCHK^INT^1^60335,48316^0 DDUCHK ;SFISC/RWF-CHECK DD ;11:25 AM 30 Dec 2004 ;;22.0;VA FileMan;**130**;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; DDUCFI=home file, DDUCFE=home field, DDUCFIX=flag to fix DD ; DDUCRFI=referenced file, DDUCRFE=referenced field. A W !!,"Check the Data Dictionary." D . W !,"Note: Messages that begin with an asterisk(*) can NOT be corrected and" . W !,"will need careful evaluation by software development!" S DDUC="" D DT^DICRW D L^DICRW1 I X'>0 D G EXIT . I X'="" Q . W !?5,"*The file: "_$P($G(Y),U,2)_"(#"_$P($G(Y),U)_") is missing its ""GL"" (Global Location) node." . W !?6,"No further checking for this file can occur!" S DDUCFIS=+X-.000001,DDUCFIE=DIB(1) S DIR(0)="Y",DIR("A")="Remove erroneous nodes",DIR("B")="NO",DIR("?",1)="This routine will try to fix certain nodes that are erroneous and may set some nodes to a file referenced by the selected file." S DIR("?")="Say 'NO' here to leave the DD untouched. It will only flag the ones it finds erroneous." D ^DIR G EXIT:$D(DIRUT) S DDUCFIX=+Y K DIR ZIS S %ZIS="Q" D ^%ZIS G EXIT:POP I $D(IO("Q")) S ZTRTN="DQ^DDUCHK",ZTSAVE("DDUCFIX")="",ZTSAVE("DDUCFIS")="",ZTSAVE("DDUCFIE")="" D ^%ZTLOAD G EXIT DQ U IO K DDUCSTK,^TMP("DDUCHK",$J) S DDUCSTK=0,DDUCFX=DDUCFIX F DDUCFILE=DDUCFIS:0:DDUCFIE S DDUCFILE=$O(^DIC(DDUCFILE)) Q:DDUCFILE'>0!(DDUCFILE>DDUCFIE) D PAGE Q:$D(DIRUT) D . N DDUERR S DDUERR=0 . W !!,"Checking file ",DDUCFILE . S (DDUCFI,DIFILE)=+DDUCFILE . D DDAC . D CHKHDR . I DDUERR Q . D CHK EXIT ; I $G(DUZ(0))="@",$D(^TMP("DDUCHK",$J)) D . W:$G(IOF)]"" @IOF . W !!,"List of ;;^^ that contain $Next" . N DDFIL S DDFIL=0 N I S I=1 N DDSP S DDSP=" " . F S DDFIL=$O(^TMP("DDUCHK",$J,DDFIL)) Q:'DDFIL D .. N DDFLD S DDFLD=0 .. F S DDFLD=$O(^TMP("DDUCHK",$J,DDFIL,DDFLD)) Q:'DDFLD D ... N DDXRN S DDXRN=0 ... F S DDXRN=$O(^TMP("DDUCHK",$J,DDFIL,DDFLD,DDXRN)) Q:'DDXRN D .... W !,I_$E(DDSP,1,(8-$L(I)))_";;"_DDFIL_U_DDFLD_U_DDXRN .... S I=I+1 . S I=9999 W !,I_$E(DDSP,1,(8-$L(I)))_";;LAST LINE" K ^TMP("DDUCHK",$J) D ^%ZISC K DDUCFI,DDUCFIX,DDUCFILE,DDUCFIS,DDUCFIE,DDUCFE,DDUCX,DDUCX1,DDUCX2,DDUCX4,DDUCRFI K DDUCRFE,DDUCSTK,DDUCSTK,DDUCDNAM,DDUCNAME,DDUCXX,DDUCY,DDUCUP,DDUCXN K DDUCF,DDUCXREF,DDUCZ,DDUC5,DDUCYY,DDUCYY1,DDUCOK,DDUCYYX,DIB,DDUC,DDUCFX,DIAC,DIFILE Q ; PAGE I $Y+3>IOSL S DIR(0)="E" D:IOST["C-" ^DIR W @IOF Q ; DDAC I DUZ(0)'="@" S DIAC="DD" D ^DIAC S DDUCFIX=DDUCFX I 'DIAC,DDUCFX W !,"You don't have DD access to this file. No fixing will be done on this file." S DDUCFIX=0 Q Q CHK I $G(^DIC(DDUCFI,0))]"",'$P(^(0),U,2) S:DDUCFIX $P(^(0),U,2)=DDUCFI I $D(^DD(DDUCFI,0))[0 S DDUCRFI=DDUCFI W !?5,"*File: "_DDUCRFI_", is missing its file header node." I $D(^DD(DDUCFI,0,"ID")) D ID^DDUCHK1 I $D(^DD(DDUCFI,0,"IX")) D IX^DDUCHK1 I $D(^DD(DDUCFI,0,"PT")) D PT^DDUCHK1 D CHKGL^DDUCHK2 D CHKSB^DDUCHK2 S DDUCNAME=$O(^DD(DDUCFI,0,"NM","")),DDUCDNAM=$O(^(DDUCNAME)),DDUCRFI=DDUCFI I DDUCDNAM]"" D WFI W "has duplicate 'NM' nodes." I DDUCFIX D NM^DDUCHK1 I $D(^DD("ACOMP",DDUCFI)) D AC^DDUCHK1 D INDEX^DDUCHK4(DDUCFI,DDUCFIX),KEY^DDUCHK5(DDUCFI,DDUCFIX) G ^DDUCHK2 WFI W !?8,"File: ",DDUCRFI," " Q ; EN ; Q:'$D(DDUCFI)!'$D(DDUCFIX) S U="^" I DDUCFI Q:'$D(^DIC(DDUCFI,0,"GL")) G EN1 Q:'$D(@(DDUCFI_"0)")) S DDUCFI=+$P(^(0),U,2) EN1 S DDUCFIS=+DDUCFI-.000001,DDUCFIE=+DDUCFI G ZIS ; CHKHDR ; Check for Missing or Incorrect File Header Node ;22*130 ;W !?5,"File: ",DDUCFI," Checking File Header Node." N DDUCGL,DDUCNA,DDUCHDR S DDUCGL=$G(^DIC(DDUCFI,0,"GL")) I DDUCGL="" W !?5,"*File: "_DDUCFI_", is missing file's ""GL"" (Global Location) node.",!?6,"No further checking can occur!" S DDUERR=1 Q S DDUCHDR=DDUCGL_"0)",DDUCHDR=$G(@DDUCHDR) S DDUCNA=$P(^DIC(DDUCFI,0),U) I DDUCHDR="" W !?5,"*File: "_DDUCFI_", is missing the File header node." Q I $P(DDUCHDR,U)'=DDUCNA W !?5,"*File: "_DDUCFI_", header name is incorrect." Q I +$P(DDUCHDR,U,2)'=DDUCFI W !?5,"*File: "_DDUCFI_" File header number is incorrect." Q Q DDUCHK1^INT^1^60335,48316^0 DDUCHK1 ;SFISC/RWF-CHECK DD part 2 ;7:08 AM 1 Oct 2003 ;;22.0;VA FileMan;**130**;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ID S DDUCRFE="" F DDUCZ=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"ID",DDUCRFE)) Q:DDUCRFE="" S DDUCX=$S($D(^DD(DDUCFI,0,"ID",DDUCRFE))#2:^(DDUCRFE),1:"") I DDUCX="Q" W !?5,"'ID' node for field ",DDUCRFE," = 'Q'" D:DDUCFIX ID1 Q ID1 K ^DD(DDUCFI,0,"ID",DDUCRFE) D M1 W """ID"",",DDUCRFE D M2 Q IX S DDUCXREF="" F DDUCZ=0:0 S DDUCXREF=$O(^DD(DDUCFI,0,"IX",DDUCXREF)) Q:DDUCXREF="" F DDUCRFI=0:0 S DDUCRFI=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI)) Q:DDUCRFI'>0 D IX1 Q IX1 D IXDUP ;22*130 F DDUCRFE=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0 D . I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D WFI W """IX"" Subscript: "_DDUCXREF_" " D WFE,WMS D:DDUCFIX IX2 Q . I $D(^DD(DDUCRFI,DDUCRFE,1,0))=0,$D(^DD(DDUCRFI,DDUCRFE,1))=10 S:DDUCFIX ^DD(DDUCRFI,DDUCRFE,1,0)="^.1" . S DDUCRFE1=0,DDUCRFEX="" F S DDUCRFE1=$O(^DD(DDUCRFI,DDUCRFE,1,DDUCRFE1)) Q:DDUCRFE1'>0 S DDUCRFEX=$G(^(DDUCRFE1,0)) I $P(DDUCRFEX,U,2)=DDUCXREF K DDUCRFEX Q . I $D(DDUCRFEX) W !?5,"Cross-reference logic is missing for """,DDUCXREF,""" x-ref" D:DDUCFIX IX2 Q K DDUCRFE1 Q IX2 K ^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE) D M1 W """IX"",",DDUCXREF_","_DDUCRFI_","_DDUCRFE D M2 Q PT F DDUCRFI=0:0 S DDUCRFI=$O(^DD(DDUCFI,0,"PT",DDUCRFI)) Q:DDUCRFI'>0 F DDUCRFE=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0 D PT1 Q PT1 I $D(^DD(DDUCRFI,0))[0 D WFI,WMS I DDUCFIX K ^DD(DDUCFI,0,"PT",DDUCRFI) D M1 W """PT"",",DDUCRFI D M2 Q I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D WFI W """PT"" Subscript " D WFE,WMS D:DDUCFIX PTM Q I ($P(^(0),U,2)'["P")&($P(^(0),U,2)'["V") D WFI,WFE W "is not a pointer." D:DDUCFIX PTM Q I $P(^(0),U,2)["P",+$P($P(^(0),U,2),"P",2)'=DDUCFI D WFI,WFE W "is not a pointer to file ",DDUCFI D:DDUCFIX PTM Q PTM K ^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE) D M1 W """PT"",",DDUCRFI,",",DDUCRFE D M2 Q AC F DDUCFE=0:0 S DDUCFE=$O(^DD("ACOMP",DDUCFI,DDUCFE)) Q:DDUCFE'>0 D AC1 Q AC1 F DDUCRFI=0:0 S DDUCRFI=$O(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI)) Q:DDUCRFI'>0 F DDUCRFE=0:0 S DDUCRFE=$O(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0 D AC2 Q AC2 I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D:DDUCFIX ACM Q S DDUCX=^(0) I $P(DDUCX,U,2)'["C" D:DDUCFIX ACM Q I $P(DDUCX,U,2)["C" S DDUCX1=$S($D(^(9.01)):^(9.01),1:""),DDUCF=0 D AC3 Q AC3 F DDUCZ=1:1 S DDUCX2=$P(DDUCX1,";",DDUCZ) Q:DDUCX2="" I DDUCX2=DDUCFI_U_DDUCFE S DDUCF=1 Q I 'DDUCF D:DDUCFIX ACM Q ACM K ^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE) Q NM S DDUCRFI(1)=$S($D(^DIC(DDUCFI,0))#2:$P(^(0),U),1:$P(^DD(DDUCFI,0)," SUB-FIELD")) Q:DDUCRFI(1)']"" K ^DD(DDUCFI,0,"NM") S ^DD(DDUCFI,0,"NM",DDUCRFI(1))="" W !?10,"Duplicate ""NM"" node was deleted." Q WHO W !?5,"Field: ",DDUCFE," (",$P(DDUCX,U),") " Q WFI W !?5,"File: ",DDUCRFI," " Q WFE W ?5,"Field: ",DDUCRFE," " Q WMS W "is missing." Q M1 W !?10,"^DD(",DDUCFI,",0," Q M2 W ") was killed." Q Q ; IXDUP ;Check for duplicate fields for same xref ;22*130 N DDUCRFE,DDUCRFEP S (DDUCRFE,DDUCRFEP)=0 S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCRFI,DDUCRFE)) D . F S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE)) Q:'DDUCRFE D .. I 'DDUCRFEP S DDUCRFEP=DDUCRFE Q .. I DDUCRFE'=DDUCRFEP D ... W !?5,"*File: ",DDUCRFI," Index: """_DDUCXREF_""" has duplicate Fields." ... W !?21,"Field: ",DDUCRFEP," Field: ",DDUCRFE .. S DDUCRFEP=DDUCRFE .. Q . S DDUCRFEP=0 . Q DDUCHK2^INT^1^60335,48316^0 DDUCHK2 ;SFISC/RWF/SO-CHECK DD (FIELDS) ;11:46 AM 5 Mar 2004 ;;22.0;VA FileMan;**100,130**;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. CHK6 ;W !?5,"Checking FIELDs" F DDUCFE=0:0 S DDUCFE=+$O(^DD(DDUCFI,DDUCFE)) Q:DDUCFE'>0 D FIELD Q:$D(DIRUT) D FIVE,DXREF^DDUCHK3,XREF^DDUCHK3,COMP^DDUCHK3 ;D CHKSB,CHKGL Q FIELD ;W "." I $D(^DD(DDUCFI,DDUCFE,0))[0 W !?5,"*Field: ",DDUCFE," is missing its zero node." Q ;22*100,22*130 S DDUCX=^DD(DDUCFI,DDUCFE,0),DDUCX2=$P(DDUCX,U,2),DDUCX4=$P(DDUCX,U,4),DDUCXN=$P(DDUCX,U) I $P(DDUCX,U,5,999)["$N(",$P(DDUCX,U,5,999)'["$$N(" W !?5,"*Field: ",DDUCFE,"'s Input Transform contains $Next." ;I DDUCX2["F",DDUCX4[";E1",$S($D(^DD(DDUCFI,DDUCFE,9)):^(9),1:"")'="@" D WHO W "doesn't have the correct protection for a field with executable code." I DDUCFIX S ^DD(DDUCFI,DDUCFE,9)="@" W !?10,"^DD(",DDUCFI,",",DDUCFE,",9) = ""@"" was set." D @$S(+DDUCX2:"MULT",DDUCX2["P":"PT",DDUCX2["V":"VP",1:"Q") Q Q FIVE K DDUCXX F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,5,DDUCY)) Q:DDUCY'>0 S DDUCX=^(DDUCY,0) I $D(^DD(+DDUCX,+$P(DDUCX,U,2),1,+$P(DDUCX,U,3),0))#2 S DDUCXX(DDUCX)="" Q:'DDUCFIX K ^DD(DDUCFI,DDUCFE,5) S DDUCX="" F DDUCY=1:1 S DDUCX=$O(DDUCXX(DDUCX)) Q:DDUCX="" S ^DD(DDUCFI,DDUCFE,5,DDUCY,0)=DDUCX Q VP F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,"V",DDUCY)) Q:DDUCY'>0 S DDUCRFI=$S($D(^DD(DDUCFI,DDUCFE,"V",DDUCY,0)):^(0),1:"") I DDUCRFI D PT1 Q PT N DDUERR S DDUCRFI=+$P(DDUCX2,"P",2),DDUERR=0 D Q:DDUERR . I $D(^DD(DDUCRFI,0))[0 W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to missing file: ",DDUCRFI S DDUERR=1 Q . N DDUCGL,DDUCNA,DDUCHDR . S DDUCGL=$G(^DIC(DDUCRFI,0,"GL")) . I DDUCGL="" W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", is missing file's ""GL"" (Global Location) node." S DDUERR=1 Q . S DDUCHDR=DDUCGL_"0)",DDUCHDR=$G(@DDUCHDR) . I DDUCHDR="" W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", missing File header node." S DDUERR=1 . Q PT1 I $D(^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE))[0 D WHO W "is missing its 'PT' node in the pointed-to-file." I DDUCFIX S ^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE)="" W !?10,"^DD(",+DDUCRFI,",0,""PT"",",DDUCFI,",",DDUCFE,") = """" was set." Q Q ;QUIT TAG MULT ;Work subfile D PAGE^DDUCHK Q:$D(DIRUT) I $D(^DD(+DDUCX2,0))[0 W !?5,"*Field: ",DDUCFE," (",DDUCXN,") missing subfile: ",+DDUCX2 Q S DDUCUP=$S($D(^DD(+DDUCX2,0,"UP")):^("UP"),1:"") I DDUCUP'=DDUCFI D WHO W "Bad 'UP' pointer in subfile #",+DDUCX2 I DDUCFIX S ^DD(+DDUCX2,0,"UP")=DDUCFI W !?10,"^DD(",+DDUCX2,",0,""UP"") = ",DDUCFI," was set." D PUSH S DDUCFI=+DDUCX2 W !?3,"Checking subfile ",DDUCFI D CHK^DDUCHK,POP W !?3,"Returning to ",$S('DDUCSTK:"main ",1:"sub"),"file",$S('DDUCSTK:" "_DDUCFILE_".",1:" "_DDUCFI) Q PUSH S DDUCSTK=DDUCSTK+1,DDUCSTK(DDUCSTK,1)=DDUCFI,DDUCSTK(DDUCSTK,2)=DDUCFE Q POP S DDUCFI=DDUCSTK(DDUCSTK,1),DDUCFE=DDUCSTK(DDUCSTK,2),DDUCSTK=DDUCSTK-1 Q WHO W !?8,"Field: ",DDUCFE," (",DDUCXN,") " Q ; CHKSB ;Check for duplicate "SB" x-refs ;22*130 N DDUCSB S DDUCSB=0 F S DDUCSB=+$O(^DD(DDUCFI,"SB",DDUCSB)) Q:'DDUCSB D . N DDUCFE,DDUCSAV,DDUNFE . S DDUCFE=0 . F S DDUCFE=+$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) Q:'DDUCFE D CHKSBA I '$D(DDUNFE),$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) D .. N DDUCFE1,DDUCX .. ;Is the TYPE "WP"? .. S DDUCX=$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) I $D(^DD(DDUCFI,DDUCX,0)),$P(^DD(DDUCFI,DDUCX,0),U,4)["WP" Q .. S DDUCSAV(DDUCFE)="" .. S DDUCFE1=DDUCFE .. F S DDUCFE1=+$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE1)) Q:'DDUCFE1 S DDUCSAV(DDUCFE1)="" . N X1,X2 . S X1=0 . F S X1=$O(DDUCSAV(X1)) Q:'X1 D .. I '$D(X2) W !?5,"*Duplicate Fields represent Sub-file: "_DDUCSB,!?7 S X2=1 .. W "field: "_X1_"; " Q ; CHKSBA ;Check if Feidl exists I '$D(^DD(DDUCFI,DDUCFE,0))#2 W !?7,"*Field: "_DDUCFE_", File: "_DDUCFI_", ""SB"" subscript for subfile: "_DDUCSB_" is missing." S DDUNFE=1 Q Q ; CHKGL ;Check for duplicate "GL" nodes ;22*130 N DDUCN S DDUCN="" F S DDUCN=$O(^DD(DDUCFI,"GL",DDUCN)) Q:DDUCN="" D . N DDUCP . S DDUCP=0 . F S DDUCP=+$O(^DD(DDUCFI,"GL",DDUCN,DDUCP)) Q:'DDUCP D .. N DDUCFE2,DDUCSAV .. S DDUCFE2=0 .. F S DDUCFE2=+$O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) Q:'DDUCFE2 I $O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) D ... S DDUCSAV(DDUCN_";"_DDUCP,DDUCFE2)="" ... N X ... S X=0 ... S X=$O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) Q:'X S DDUCSAV(DDUCN_";"_DDUCP,X)="" .. N X1,X2 .. S X1="" ;Global Location .. F S X1=$O(DDUCSAV(X1)) Q:X1="" D ... I '$D(X2) W !?5,"*Duplication at global location subscript: "_$P(X1,";")_", piece: "_$P(X1,";",2),!?9 S X2=1 ... N X3 ... S X3=0 ;Field # ... F S X3=$O(DDUCSAV(X1,X3)) Q:'X3 W "field: "_X3_"; " Q DDUCHK3^INT^1^60335,48316^0 DDUCHK3 ;SFISC/RWF-CHECK DD (XREF,COMPUTED) ;12:40 PM 4 Mar 2004 ;;22.0;VA FileMan;**130**;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. XREF F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,1,DDUCY)) Q:DDUCY'>0 S DDUCX=^(DDUCY,0),DDUCRFI=+DDUCX,DDUCX1=$P(DDUCX,U,2) D XREF1 Q XREF1 ; I DDUCRFI,$D(^DD(DDUCRFI,0)),$D(^DD(DDUCRFI,0,"IX",DDUCX1,DDUCFI,DDUCFE))[0 D WHO,WFI W "missing 'IX' node." D:DDUCFIX XREFM Q I DDUCX["TRIGGER" S DDUCRFI=+$P(DDUCX,U,4),DDUCRFE=+$P(DDUCX,U,5),DDUC5=DDUCFI_U_DDUCFE_U_DDUCY D TRIG Q XREFM S ^DD(DDUCRFI,0,"IX",DDUCX1,DDUCFI,DDUCFE)="" W !?10,"^DD(",DDUCRFI,",0,""IX"",""",DDUCX1,""",",DDUCFI,",",DDUCFE,") = """" was set." Q TRIG I $D(^DD(DDUCRFI,0))[0 W !?5,"Field: ",DDUCFE," (",DDUCXN,") triggers missing file ",DDUCRFI Q I $D(^DD(DDUCRFI,DDUCRFE,0))[0 W !?5,"*Field: ",DDUCFE," (",DDUCXN,") triggers missing field ",DDUCRFE," in file ",DDUCRFI Q I '$D(^DD(DDUCRFI,DDUCRFE,5)) D WHO,WFI,WFE W " 5 node is missing." I DDUCFIX S ^DD(DDUCRFI,DDUCRFE,5,1,0)=DDUC5 W !?10,"^DD(",DDUCRFI,",",DDUCRFE,",5,1,0) = ",DDUC5," was set." Q Q:'DDUCFIX S (DDUCYY1,DDUCOK)=0 F DDUCYY=0:0 S DDUCYY=$O(^DD(DDUCRFI,DDUCRFE,5,DDUCYY)) Q:DDUCYY'>0 S DDUCYY1=DDUCYY,DDUCYYX=^(DDUCYY,0) I DDUCYYX=DDUC5 S DDUCOK=1 Q I 'DDUCOK D WHO,WFI,WFE W " 5 node is missing." D:DDUCFIX TRIGM Q Q TRIGM S ^DD(DDUCRFI,DDUCRFE,5,(DDUCYY1+1),0)=DDUC5 I DDUCRFI'=DDUCFE W !?10,"^DD(",DDUCRFI,",",DDUCRFE,",5,",DDUCYY1+1,",0) = ",DDUC5," was set." Q COMP Q:DDUCX2'["C" S DDUCX=$S($D(^DD(DDUCFI,DDUCFE,9.01)):^(9.01),1:"") F DDUCX1=1:1 Q:$P(DDUCX,";",DDUCX1)="" S DDUCRFI=+$P(DDUCX,";",DDUCX1),DDUCRFE=+$P($P(DDUCX,";",DDUCX1),U,2) I $D(^DD("ACOMP",DDUCRFI,DDUCRFE,DDUCFI,DDUCFE))[0 S:DDUCFIX ^DD("ACOMP",DDUCRFI,DDUCRFE,DDUCFI,DDUCFE)="" Q WHO W !?8,"Field: ",DDUCFE," (",DDUCXN,") " Q WFI W !?8,"File: ",DDUCRFI," " Q WFE W ?8,"Field: ",DDUCRFE," " Q ; DXREF ; Check for $Next usage; 22*130 ; DDUCFI = File # ; DDUCFE = Field # ; XRN = Cross Reference # N XRN S XRN=0 F S XRN=$O(^DD(DDUCFI,DDUCFE,1,XRN)) Q:'XRN D . ; XRN1 = Cross Reference Node Data . N XRN1 S XRN1="" . ; XRNW = 0 Have Not written warning, 1 have written warning . N XRNW S XRNW=0 . F S XRN1=$O(^DD(DDUCFI,DDUCFE,1,XRN,XRN1)) Q:XRN1="" D .. N GMSG S GMSG=0 ;1 equals use general message .. I XRN1="%D" Q .. I XRN1="DT" Q .. ; Check for $Next any cross reference code .. I ^DD(DDUCFI,DDUCFE,1,XRN,XRN1)["$N(",^DD(DDUCFI,DDUCFE,1,XRN,XRN1)'["$$N(" D I GMSG W !?5,"*Field: ",DDUCFE,", Cross Reference #: ",XRN,", Sub-Script: ",XRN1,", contains $Next." ... I $P(^DD(DDUCFI,DDUCFE,1,XRN,0),U,3)'="TRIGGER" S GMSG=1 Q ... ; Display/Fix known old FileMan TRIGGER Code: ... ; "D ^DICR:$N(^DD(DIH,DIG,1,0))>0" ... N DICRVAL ... S DICRVAL=$G(^DD(DDUCFI,DDUCFE,1,XRN,XRN1)) ... I DICRVAL'["D ^DICR:$N(^DD(DIH,DIG,1,0))>0" S GMSG=1 Q ... I 'XRNW D .... W !?5,"*File: "_DDUCFI_", Field: "_DDUCFE_", XREF: "_XRN_" contains $Next in TRIGGER code." .... S ^TMP("DDUCHK",$J,DDUCFI,DDUCFE,XRN)="" .... S XRNW=1 Q DDUCHK4^INT^1^60335,48316^0 DDUCHK4 ;SFISC/MKO-CHECK INDEXES ON FILE ;6:36 AM 28 Dec 2004 ;;22.0;VA FileMan;*130*;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; INDEX(DDUCFI,DDUCFIX) ;Check and optionally fix structure of Index file entry N DDUCIX Q:'$G(DDUCFI) S DDUCFIX=$G(DDUCFIX) ; ;Loop through "B" index to find INDEXes that reside on this file D WCHK S DDUCIX="" F S DDUCIX=$O(^DD("IX","B",DDUCFI,DDUCIX)) Q:DDUCIX="" D CHKIX ; ;Check "AC","BB", and "F" indexes D CHKAC,CHKBB,CHKF Q ; CHKIX ;Check Index DDUCIX found in "B" index ;In: ; DDUCIX = index # ; DDUCFI = file # ; DDUCFIX = flag to fix N DDUCIX0,DDUCIXID,DDUCNM,DDUCRF,DDUCRV S DDUCIXID=$$IXID(DDUCIX,"") ; ;Check that Index exists I '$D(^DD("IX",DDUCIX)) D Q . D WNOIX . D:DDUCFIX KILL($NA(^DD("IX","B",DDUCFI,DDUCIX))) ; ;Check that index has a FILE S DDUCIX0=$G(^DD("IX",DDUCIX,0)) I $P(DDUCIX0,U)="" D . D WMS("FILE (#.01) for "_DDUCIXID) . D:DDUCFIX FFILE ; ;Get Name S DDUCNM=$P(DDUCIX0,U,2) I DDUCNM]"" S DDUCIXID=$$IXID(DDUCIX,DDUCNM) E D WMS("NAME for "_DDUCIXID) ; ;Check Root File not null, and "AC" index exists S DDUCRF=$P(DDUCIX0,U,9) I 'DDUCRF D . D WMS("ROOT FILE for "_DDUCIXID) . D:DDUCFIX FRF ; ;Check Cross-Reference Values multiple S DDUCRV=0 F S DDUCRV=$O(^DD("IX",DDUCIX,11.1,DDUCRV)) Q:'DDUCRV D CRV ; ;Reindex Index file entry I DDUCFIX D . N DIC,DIK,DA,X . S DIK="^DD(""IX"",",DA=DDUCIX . D IX^DIK Q ; CRV ;Check a Cross-Reference Value ;In: ; DDUCIX = Index # ; DDUCRV = CRV # ; DDUCFIX = Flag to fix ; DDUCRF = Root file # ; DDUCIXID = String that identifies Index N DDUCFIL,DDUCFLD,DDUCGL,DDUCOID,DDUCORD,DDUCRV0 ; S DDUCRV0=$G(^DD("IX",DDUCIX,11.1,DDUCRV,0)) Q:$P(DDUCRV0,U,2)="C" S DDUCORD=$P(DDUCRV0,U),DDUCFIL=$P(DDUCRV0,U,3),DDUCFLD=$P(DDUCRV0,U,4) ; ;Check .01 of CRV I DDUCORD="" D . D WMS("ORDER NUMBER of Cross-Reference Value #"_DDUCRV_" of "_DDUCIXID) . D:DDUCFIX FON S DDUCOID=$$OID(DDUCORD,"","",DDUCIXID) ; ;Make sure FILE is not null I 'DDUCFIL D . D WMS("FILE for "_DDUCOID,1) ; ;If there's a File, make sure it is equal to Root File ;and that referenced field exists. E D . D:DDUCFIL'=DDUCRF WNE . D:$D(^DD(DDUCFIL,DDUCFLD,0))[0 WFMS . I $D(^DD("IX","F",DDUCFIL,DDUCFLD,DDUCIX,DDUCRV))[0 S DDUCGL=$NA(^(DDUCRV)) D .. D WMS(DDUCGL) .. D:DDUCFIX SET(DDUCGL) Q ; CHKAC ;Check "AC index (In: DDUCFI = file; DDUCFIX = flag to fix) N DDUCGL,DDUCIX S DDUCIX=0 F S DDUCIX=$O(^DD("IX","AC",DDUCFI,DDUCIX)) Q:'DDUCIX D . I $P($G(^DD("IX",DDUCIX,0)),U,9)]"",$P(^(0),U,9)'=DDUCFI D .. S DDUCGL=$NA(^DD("IX","AC",DDUCFI,DDUCIX)) .. D WEN(DDUCGL) .. D:DDUCFIX KILL(DDUCGL) Q ; CHKBB ;Check "BB" index (In: DDUCFI = file; DDUCFIX = flag to fix) N DDUCGL,DDUCIX,DDUCIX0,DDUCIXID,DDUCNM,DDUCNML S DDUCNM="" F S DDUCNM=$O(^DD("IX","BB",DDUCFI,DDUCNM)) Q:DDUCNM="" D . S DDUCIX=0 . F DDUCIX=$O(^DD("IX","BB",DDUCFI,DDUCNM,DDUCIX)) Q:'DDUCIX D .. S DDUCIX0=$G(^DD("IX",DDUCIX,0)) .. I $D(^DD("IX",DDUCIX)),$P(DDUCIX0,U,2)="" S DDUCNML(DDUCIX,DDUCNM)="" .. E I $P(DDUCIX0,U)'=DDUCFI!($P(DDUCIX0,U,2)'=DDUCNM) D ... S DDUCGL=$NA(^DD("IX","BB",DDUCFI,DDUCNM,DDUCIX)) ... D WEN(DDUCGL) ... D:DDUCFIX KILL(DDUCGL) ; ;If any of the Indexes have null Names, check whether a single name ;for it was found in the "BB" index. I $D(DDUCNML) S DDUCIX=0 F S DDUCIX=$O(DDUCNML(DDUCIX)) Q:'DDUCIX D . S DDUCNM=$O(DDUCNML(DDUCIX,"")) . I $O(DDUCNML(DDUCIX,DDUCNM))="" D .. S DDUCIXID=$$IXID(DDUCIX,"") .. D WNM .. D:DDUCFIX FNM . E F D S DDUCNM=$O(DDUCNML(DDUCIX,DDUCNM)) Q:DDUCNM="" .. S DDUCGL=$NA(^DD("IX","BB",DDUCFI,DDUCNM,DDUCIX)) .. D WEN(DDUCGL) .. D:DDUCFIX KILL(DDUCGL) Q ; CHKF ;Check "F" index (In: DDUCFI = file; DDUCFIX = flag to fix) N DDUCFLD,DDUCGL,DDUCIX,DDUCRV S DDUCFLD=0 F S DDUCFLD=$O(^DD("IX","F",DDUCFI,DDUCFLD)) Q:'DDUCFLD D . S DDUCIX=0 . F S DDUCIX=$O(^DD("IX","F",DDUCFI,DDUCFLD,DDUCIX)) Q:'DDUCIX D .. S DDUCRV=0 .. F S DDUCRV=$O(^DD("IX","F",DDUCFI,DDUCFLD,DDUCIX,DDUCRV)) Q:'DDUCRV D ... I $P($G(^DD("IX",DDUCIX,11.1,DDUCRV,0)),U,3)'=DDUCFI!($P($G(^(0)),U,4)'=DDUCFLD) D .... S DDUCGL=$NA(^DD("IX","F",DDUCFI,DDUCFLD,DDUCIX,DDUCRV)) .... D WEN(DDUCGL) .... D:DDUCFIX KILL(DDUCGL) Q ; ;--------------- FFILE ;Set the .01 of index to DDUCFI S $P(^DD("IX",DDUCIX,0),U)=DDUCFI D WRITE("FILE (#.01) for "_DDUCIXID_" set to "_DDUCFI_".",10) Q ; FRF ;Set Root File equal to File and Root Type to 'INDEX FILE' S $P(^DD("IX",DDUCIX,0),U,8)="I" S $P(^DD("IX",DDUCIX,0),U,9)=DDUCFI S DDUCRF=DDUCFI D WRITE("ROOT FILE for "_DDUCIXID_" set to "_DDUCFI_".",10) D WRITE("ROOT TYPE for "_DDUCIXID_" set to 'INDEX FILE'.",10) Q ; FON ;Determine Order Number N DDUCI,DDUCO ; ;Look for Order Number in "B" index S DDUCORD=0 F S DDUCORD=$O(^DD("IX",DDUCIX,11.1,"B",DDUCORD)) Q:'DDUCORD Q:$O(^DD("IX",DDUCIX,11.1,"B",DDUCORD,0))=DDUCRV ; ;If not found, just pick an unused Order Number I 'DDUCORD D . S DDUCI=0 . F S DDUCI=$O(^DD("IX",DDUCIX,11.1,DDUCI)) Q:'DDUCI S:$P($G(^(DDUCI,0)),U)]"" DDUCO($P(^(0),U))="" . S DDUCORD=$O(DDUCO(""),-1) . S:'DDUCORD DDUCORD=1 ; S $P(^DD("IX",DDUCIX,11.1,DDUCRV,0),U)=DDUCORD D WRITE("ORDER NUMBER for Cross-Reference Value #"_DDUCRV_" of "_DDUCIXID_" set to "_DDUCORD_".",10) Q ; FNM ;Set the NAME for the Index S $P(^DD("IX",DDUCIX,0),U,2)=DDUCNM D WRITE("NAME for "_DDUCIXID_" set to '"_DDUCNM_"'.",10) Q ; KILL(GL) ;Kill a global and print a message Q:'$D(@GL) K @GL W !?10,GL_" was killed." Q ; SET(GL,VAL) ;Set a global and print a message Q:$D(@GL) S VAL=$G(VAL),@GL=VAL W !?10,GL_" was set"_$S(VAL]"":" to "_VAL,1:"")_"." Q ; ;Write messages WCHK Q ;D WRITE("Checking Indexes.",5) Q WNOIX D WRITE(DDUCIXID_" does not exist.",7) Q WMS(S,N) D WRITE("*"_S_" is missing."_$S($G(N):" ",1:""),7) Q WNE D WRITE("*FILE does not equal ROOT FILE in "_DDUCOID_".",7) Q ;22*130 WFMS D WRITE("*File/Sub-file #"_$S($G(FIL)'="":FIL,1:DDUCFIL)_", Field #"_$S($G(FLD)'="":FLD,1:DDUCFLD)_" referenced in "_DDUCOID_" is missing.",7) Q ;22*130 WEN(GL) D WRITE("Erroneous node "_GL_" is set.",7) Q WNM D WRITE("NAME for "_DDUCIXID_" looks like it should be '"_DDUCNM_"'.",7) Q ; WRITE(TXT,TAB) ;Write text, wrap at word boundaries. N I D WRAP^DIKCU2(.TXT,-TAB-2,-TAB) W !?TAB,$G(TXT,$G(TXT(0))) F I=1:1 Q:'$D(TXT(I)) W !?TAB+2,TXT(I) Q ; IXID(IX,NM) ;Return string that identifies an Index S:'$D(NM) NM=$P($G(^DD("IX",IX,0)),U,2) Q $S(NM]"":"'"_NM_"' Index (#"_IX_")",1:"Index #"_IX) ; OID(ORD,IX,NM,IXID) ;Return string that identifies Cross-Reference Value I '$D(IXID),$G(IX) S IXID=$S($D(NM)#2:$$IXID(IX,NM),1:$$IXID(IX)) Q "Order #"_ORD_" of "_$S($G(IXID)]"":IXID,1:"") DDUCHK5^INT^1^60335,48316^0 DDUCHK5 ;SFISC/MKO-CHECK KEYS ON FILE ;8/8/03 06:26 ;;22.0;VA FileMan;*130*;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; KEY(DDUCFI,DDUCFIX) ;Check and optionally fix structure of Key file entry N DDUCKEY Q:'$G(DDUCFI) S DDUCFIX=$G(DDUCFIX) ; ;Loop through "B" index to find KEYs that reside on this file D WCHK S DDUCKEY="" F S DDUCKEY=$O(^DD("KEY","B",DDUCFI,DDUCKEY)) Q:DDUCKEY="" D CHKKEY ; ;Check "AP","BB", and "F" indexes D CHKAP,CHKBB,CHKF Q ; CHKKEY ;Check Key DDUCKEY found in "B" index ;In: ; DDUCKEY = Key # ; DDUCFI = File # ; DDUCFIX = Flag to fix N DDUCIEN,DDUCKEY0,DDUCKID,DDUCNM,DDUCUI S DDUCKID=$$KEYID(DDUCKEY,"") ; ;Check that Key exists I '$D(^DD("KEY",DDUCKEY)) D Q . D WNOKEY . D:DDUCFIX KILL($NA(^DD("KEY","B",DDUCFI,DDUCKEY))) ; ;Check that Key has a FILE S DDUCKEY0=$G(^DD("KEY",DDUCKEY,0)) I $P(DDUCKEY0,U)="" D . D WMS("FILE (#.01) for "_DDUCKID) . D:DDUCFIX FFILE ; ;Get Name S DDUCNM=$P(DDUCKEY0,U,2) I DDUCNM]"" S DDUCKID=$$KEYID(DDUCKEY,DDUCNM) E D WMS("NAME for "_DDUCKID) ; ;Check Priority S DDUCPRI=$P(DDUCKEY0,U,3) D:DDUCPRI="" WMS("PRIORITY for "_DDUCKID) ; ;Check Uniqueness Index S DDUCUI=$P(DDUCKEY0,U,4) I 'DDUCUI D . D WMS("Uniqueness Index for "_DDUCKID,1) E D . I '$D(^DD("IX",DDUCUI,0)) D Q .. D WMS("Dangling pointer. Uniqueness Index #"_DDUCUI_" pointed to by "_DDUCKID,1) . D GETFLD^DIKKUTL2(DDUCKEY,DDUCUI,.DDUCKFLD,.DDUCUFLD) . D:'$$GCMP^DIKCU2("DDUCKFLD","DDUCUFLD") WNE ; ;Check Field multiple S DDUCIEN=0 F S DDUCIEN=$O(^DD("KEY",DDUCKEY,2,DDUCIEN)) Q:'DDUCIEN D FLD ; ;Reindex Key file entry I DDUCFIX D . N DIC,DIK,DA,X . S DIK="^DD(""KEY"",",DA=DDUCKEY . D IX^DIK Q ; FLD ;Check a Cross-Reference Value ;In: ; DDUCKEY = Key # ; DDUCIEN = IEN in FIELD multiple ; DDUCFIX = Flag to fix ; DDUCKID = String that identifies Key ; DDUCUI = Uniqueness index # N DDUCFIL,DDUCFLD,DDUCFLD0,DDUCKFLD,DDUCSEQ,DDUCUFLD ; S DDUCFLD0=$G(^DD("KEY",DDUCKEY,2,DDUCIEN,0)) S DDUCFLD=$P(DDUCFLD0,U),DDUCFIL=$P(DDUCFLD0,U,2) S DDUCSEQ=$P(DDUCFLD0,U,3) ; ;Check that field, file, and sequence are filled in D:'DDUCFLD!'DDUCFIL!'DDUCSEQ WINC ; ;Make sure file/field exists and is in the "F" index I DDUCFLD,DDUCFIL D . D:$D(^DD(DDUCFIL,DDUCFLD,0))[0 WFMS . I $D(^DD("KEY","F",DDUCFIL,DDUCFLD,DDUCKEY,DDUCIEN))[0 S DDUCGL=$NA(^(DDUCIEN)) D .. D WMS(DDUCGL) .. D:DDUCFIX SET(DDUCGL) Q ; CHKAP ;Check "AP" index (In: DDUCFI = file; DDUCFIX = flag to fix) N DDUCGL,DDUCKEY,DDUCKEY0,DDUCPRI,DDUCPRIL ; S DDUCPRI="" F S DDUCPRI=$O(^DD("KEY","AP",DDUCFI,DDUCPRI)) Q:DDUCPRI="" D . S DDUCKEY=0 . F S DDUCKEY=$O(^DD("KEY","AP",DDUCFI,DDUCPRI,DDUCKEY)) Q:'DDUCKEY D .. S DDUCKEY0=$G(^DD("KEY",DDUCKEY,0)) .. I $D(^DD("KEY",DDUCKEY)),$P(DDUCKEY0,U,3)="" S DDUCPRIL(DDUCKEY,DDUCPRI)="" .. E I $P(DDUCKEY0,U)'=DDUCFI!($P(DDUCKEY0,U,3)'=DDUCPRI) D ... S DDUCGL=$NA(^DD("KEY","AP",DDUCFI,DDUCPRI,DDUCKEY)) ... D WEN(DDUCGL) ... D:DDUCFIX KILL(DDUCGL) ; ;If any of the Keys have null Priorities, check whether a single ;priority for it was found in the "AP" index. I $D(DDUCPRIL) S DDUCKEY=0 F S DDUCKEY=$O(DDUCPRIL(DDUCKEY)) Q:'DDUCKEY D . S DDUCPRI=$O(DDUCPRIL(DDUCKEY,"")) . I $O(DDUCPRIL(DDUCKEY,DDUCPRI))="" D .. S DDUCKID=$$KEYID(DDUCKEY) .. D WPRI .. D:DDUCFIX FPRI . E F D S DDUCPRI=$O(DDUCPRIL(DDUCKEY,DDUCPRI)) Q:DDUCPRI="" .. S DDUCGL=$NA(^DD("KEY","AP",DDUCFI,DDUCPRI,DDUCKEY)) .. D WEN(DDUCGL) .. D:DDUCFIX KILL(DDUCGL) Q ; CHKBB ;Check "BB" index (In: DDUCFI = file; DDUCFIX = flag to fix) N DDUCGL,DDUCKEY,DDUCKEY0,DDUCKID,DDUCNM,DDUCNML S DDUCNM="" F S DDUCNM=$O(^DD("KEY","BB",DDUCFI,DDUCNM)) Q:DDUCNM="" D . S DDUCKEY=0 . F DDUCKEY=$O(^DD("KEY","BB",DDUCFI,DDUCNM,DDUCKEY)) Q:'DDUCKEY D .. S DDUCKEY0=$G(^DD("KEY",DDUCKEY,0)) .. I $D(^DD("KEY",DDUCKEY)),$P(DDUCKEY0,U,2)="" S DDUCNML(DDUCKEY,DDUCNM)="" .. E I $P(DDUCKEY0,U)'=DDUCFI!($P(DDUCKEY0,U,2)'=DDUCNM) D ... S DDUCGL=$NA(^DD("KEY","BB",DDUCFI,DDUCNM,DDUCKEY)) ... D WEN(DDUCGL) ... D:DDUCFIX KILL(DDUCGL) ; ;If any of the Keys have null Names, check whether a single name ;for it was found in the "BB" index. I $D(DDUCNML) S DDUCKEY=0 F S DDUCKEY=$O(DDUCNML(DDUCKEY)) Q:'DDUCKEY D . S DDUCNM=$O(DDUCNML(DDUCKEY,"")) . I $O(DDUCNML(DDUCKEY,DDUCNM))="" D .. S DDUCKID=$$KEYID(DDUCKEY,"") .. D WNM .. D:DDUCFIX FNM . E F D S DDUCNM=$O(DDUCNML(DDUCKEY,DDUCNM)) Q:DDUCNM="" .. S DDUCGL=$NA(^DD("KEY","BB",DDUCFI,DDUCNM,DDUCKEY)) .. D WEN(DDUCGL) .. D:DDUCFIX KILL(DDUCGL) Q ; CHKF ;Check "F" index (In: DDUCFI = file; DDUCFIX = flag to fix) N DDUCFLD,DDUCGL,DDUCKEY,DDUCIEN S DDUCFLD=0 F S DDUCFLD=$O(^DD("KEY","F",DDUCFI,DDUCFLD)) Q:'DDUCFLD D . S DDUCKEY=0 . F S DDUCKEY=$O(^DD("KEY","F",DDUCFI,DDUCFLD,DDUCKEY)) Q:'DDUCKEY D .. S DDUCIEN=0 .. F S DDUCIEN=$O(^DD("KEY","F",DDUCFI,DDUCFLD,DDUCKEY,DDUCIEN)) Q:'DDUCIEN D ... I $P($G(^DD("KEY",DDUCKEY,2,DDUCIEN,0)),U,2)'=DDUCFI!($P($G(^(0)),U)'=DDUCFLD) D .... S DDUCGL=$NA(^DD("KEY","F",DDUCFI,DDUCFLD,DDUCKEY,DDUCIEN)) .... D WEN(DDUCGL) .... D:DDUCFIX KILL(DDUCGL) Q ; ;--------------- FFILE ;Set the .01 of Key to DDUCFI S $P(^DD("KEY",DDUCKEY,0),U)=DDUCFI D WRITE("FILE (#.01) for "_DDUCKID_" set to "_DDUCFI_".",10) Q ; FNM ;Set the NAME for the Key S $P(^DD("KEY",DDUCKEY,0),U,2)=DDUCNM D WRITE("NAME for "_DDUCKID_" set to '"_DDUCNM_"'.",10) Q ; FPRI ;Set the PRIORITY for the Key S $P(^DD("KEY",DDUCKEY,0),U,3)=DDUCPRI D WRITE("PRIORITY for "_DDUCKID_" set to '"_DDUCPRI_"'.",10) Q ; KILL(GL) ;Kill a global and print a message Q:'$D(@GL) K @GL W !?10,GL_" was killed." Q ; SET(GL,VAL) ;Set a global and print a message Q:$D(@GL) S VAL=$G(VAL),@GL=VAL W !?10,GL_" was set"_$S(VAL]"":" to "_VAL,1:"")_"." Q ; ;Write messages WCHK Q ;D WRITE("Checking Keys.",5) Q WNOKEY D WRITE(DDUCKID_" does not exist.",7) Q WMS(S,N) D WRITE(S_" is missing."_$S($G(N):" Nothing done.",1:""),7) Q WINC D WRITE("Field information in "_DDUCKEY_" is incomplete. Nothing done.",7) Q WFMS D WRITE("*File #"_DDUCFIL_", Field #"_DDUCFLD_" referenced in "_DDUCKEY_" is missing.",7) Q ;22*130 WNE D WRITE("*Fields in "_DDUCKID_" don't match fields in Uniqueness Index.",7) Q ;22*130 WEN(GL) D WRITE("Erroneous node "_GL_" is set.",7) Q WNM D WRITE("NAME for "_DDUCKID_" looks like it should be '"_DDUCNM_"'.",7) Q WPRI D WRITE("PRIORITY for "_DDUCKID_" looks like it should be '"_DDUCPRI_"'.",7) Q ; WRITE(TXT,TAB) ;Write text, wrap at word boundaries. N I D WRAP^DIKCU2(.TXT,-TAB-2,-TAB) W !?TAB,$G(TXT,$G(TXT(0))) F I=1:1 Q:'$D(TXT(I)) W !?TAB+2,TXT(I) Q ; KEYID(KEY,NM) ;Return string that identifies a Key S:'$D(NM) NM=$P($G(^DD("KEY",KEY,0)),U,2) Q $S(NM]"":"Key '"_NM_"' (#"_KEY_")",1:"Key #"_KEY) DDW^INT^1^^0 DDW ;SFISC/PD KELTZ-SCREEN EDITOR MAIN ROUTINE ;24MAR2006 ;;22.0;VA FileMan;**8,18,999,1004,1023**;Mar 30, 1999 MAIN N DX,DY,IOTM,IOBM I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU ; D INIT I $G(DDWERR) K DDWERR Q D ^DDWT1,END Q ; EDIT(DIC,DDWFLAGS,DIWETXT,DIWESUB,DDWRW,DDWC,DDWTM,DDWBM,DDWLMAR,DDWRMAR,DDWAUTO,DDWTAB) ;DDWRW=ROW # N DWHD,DWLC,DDWEDIT,DDWRWSET S DDWEDIT=1,DDWRWSET=1 ;WE MEAN IT G MAIN ; MSG(DDWX) ;Write message S DY=$G(DDWBM,IOSL)-1,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)_$G(DDWX) I $G(DDWX)="",$D(DDWMARK) D IND^DDW7(1) Q ; INIT ;Setup, initialize variables N X,DDWI K DIERR D INIT^DDGLIB0() G:$G(DIERR) ERR I $P(DDGLED,DDGLDEL,2)_$P(DDGLED,DDGLDEL,3)_$P(DDGLED,DDGLDEL,4)="" D TRMERR^DDGLIB0("Set Top and Bottom Margins, Delete Line, and Insert Line") G ERR ; G:'$D(DIC) FERR S DDWDIC=$$CREF^DILF(DIC) S X="S X="_DDWDIC D ^DIM G:'$D(X) FERR G:'$D(@DDWDIC) FERR S DDWDIC=$NA(@DDWDIC) S DIC=$$OREF^DILF(DDWDIC) ; I IOSL>100 S DDWIOSL=IOSL,IOSL=24 S IOTM=$G(DDWTM,1)+2,IOBM=$G(DDWBM,IOSL)-3 MAR I IOBM-IOTM<3 D BLD^DIALOG(202,$$EZBLD^DIALOG(831)) G ERR ;**'TOP & BOTTOM' ; S:'$G(DDWLMAR) DDWLMAR=1 S:'$G(DDWRMAR) DDWRMAR=74 I DDWRMAR'>DDWLMAR!(DDWLMAR>231)!(DDWRMAR>245) D BLD^DIALOG(202,"Left and/or Right Margin") G ERR ; D:$D(DDW("IN"))[0 GETKEY^DDWK ; D CLR W:$P(DDGLED,DDGLDEL,2)]"" @$P(DDGLED,DDGLDEL,2) X DDGLZOSF("EOFF"),DDGLZOSF("TRMON") ; K DDWL,^TMP("DDW",$J),^TMP("DDW1",$J) S (DDWA,DDWSTB,DDWSTAT)=0,DDWBF="0010" ; S DDWREP=$G(DDWFLAGS)["R" S DDWRAP=$G(DDWFLAGS)'["M" I 'DDWRAP D . S DDWLMAR(1)=DDWLMAR,DDWLMAR=1 . S DDWRMAR(1)=DDWRMAR,DDWRMAR=245 ; I '$G(DDWRW),$G(DDWRW)'="B" S DDWRW=1 I '$G(DDWC),$G(DDWC)'="E" S DDWC=1 ; S DDWTO=DTIME S DDWOFS="0^20^^1",$P(DDWOFS,U,3)=IOM-$P(DDWOFS,U,2) S DDWMR=IOBM-IOTM+1 ; S:$G(DDWTAB)="" DDWTAB="+8" S DDWRUL=$$RULER^DDW2(DDWTAB) ; I $G(DDWAUTO) D . N DDWX,DDWERR . S (DDWAUTO,DDWX)=$E(DDWAUTO,1,15) . D AUTOVAL^DDW1 . I $D(DDWERR)#2!($G(DDWAUTO)'>0) K DDWAUTO Q . S DDWAUTO("H")=$H . S DDWAUTO("S")=DDWAUTO*60 E K DDWAUTO Q ; RESET ;Reset terminal and cleanup K DIERR D INIT^DDGLIB0() D:$G(DIERR) MSG^DIALOG("BW") W $P($G(DDGLVID),DDGLDEL,10) ; END ;Cleanup S:$D(DDWIOSL)#2 IOSL=DDWIOSL I $P(DDGLED,DDGLDEL,2)]"" D . S IOTM=1,IOBM=$S($D(IOSL)#2:IOSL,1:24) W @$P(DDGLED,DDGLDEL,2) D CLR ; K DDW,DDWA,DDWBF,DDWC,DDWCHG,DDWCNT,DDWDIC,DDWED,DDWFIN,DDWFIND,DDWHLOG K DDWIOSL,DDWL,DDWMARK,DDWMR,DDWN,DDWOFS,DDWQ,DDWRAP,DDWREP K DDWRUL,DDWRW,DDWSTAT,DDWSTB,DDWTC,DDWTO K ^TMP("DDW",$J),^TMP("DDW1",$J),^TMP("DDWH",$J) I $$ROUEXIST^DILIBF("XPDUTL"),$$VERSION^XPDUTL("XU")>7.1 E K ^TMP("DDWB",$J) ; ;D:'$D(DIWE) X^DIWE I $D(DDS) D . D:$D(DIWESW) KILL^DDGLIB0("K") E D KILL^DDGLIB0($G(DDWFLAGS)) Q ; CLR ;Clear screen I $G(DDWTM,1)=1,$G(DDWBM,IOSL)=IOSL W $P(DDGLCLR,DDGLDEL,2) E D . S DX=0 . F DY=$G(DDWTM,1)-1:1:$G(DDWBM,IOSL)-1 X IOXY W $P(DDGLCLR,DDGLDEL) Q ; FERR ;File input parameter error D BLD^DIALOG(202,"File") D ERR Q ; ERR ;Error during setup W $C(7),! D MSG^DIALOG("BW") W ! D KILL^DDGLIB0() S DDWERR=1 Q DDW1^INT^1^60300,29510^0 DDW1 ;SFISC/PD KELTZ-LOAD, SAVE ;06:11 PM 25 Aug 2002 ;;22.0;VA FileMan;**18,999**;Mar 30, 1999 ; LOAD ;Put up "box" and load document N DDWI,DDWX D BOX ; I $D(DWLC)[0 D . S DWLC=$S($D(@DDWDIC@(0))#2:+$P(@DDWDIC@(0),U,4),1:$O(@DDWDIC@(""),-1)) . S:$D(@DDWDIC@(1))#2 $E(DDWBF,4)=1 S DDWCNT=$S(DWLC:DWLC,1:1) ;HOW MANY LINES WE HAVE TOTAL ; D:DDWCNT>1 MSG^DDW("...") F DDWI=DDWCNT:-1:DDWMR+1 D ;PUT HIDDEN LINES INTO ^TMP . S DDWSTB=DDWSTB+1 . S DDWX=$S('$E(DDWBF,4):$G(@DDWDIC@(DDWI,0)),1:$G(@DDWDIC@(DDWI))) . D:DDWX?.E1C.E CTRL . S ^TMP("DDW1",$J,DDWSTB)=DDWX ; F DDWI=1:1:DDWMR D ;start writing from line 1 (!) . S DDWX=$S(DDWI>DDWCNT:"",'$E(DDWBF,4):$G(@DDWDIC@(DDWI,0)),1:$G(@DDWDIC@(DDWI))) . D:DDWX?.E1C.E CTRL . S DDWL(DDWI)=DDWX . I DDWC'>IOM,DDWRW'>DDWMR,DDWI'>DDWCNT,DDWX'?." " D .. D CUP(DDWI,1) W $E(DDWX,1,IOM) ;HERE'S WHERE A LINE IS WRITTEN OUT ; I DDWCNT=1,DDWL(1)?1." " S DDWL(1)="" D:DDWCNT>1 MSG^DDW() ; CTRLREM D:$G(DDWED) MSG^DDW($C(7)_$P(DDGLVID,DDGLDEL,6)_$$EZBLD^DIALOG(8128)_$P(DDGLVID,DDGLDEL,10)) ;**'CONTROL CHARACTERS REPLACED' ; I DDWRW="B" D . D BOT^DDW3 E D LINE^DDWG(DDWRW,DDWC) Q ; CTRL ;Strip control characters from DDWX N I S DDWED=1 F I=1:1:$L(DDWX) S:$E(DDWX,I)?1C $E(DDWX,I)=" " Q ; BOX ;Draw box N DDWX ; I $D(DIWETXT) D . D CUP(-1,1) . W $P(DDGLVID,DDGLDEL)_$E(DIWETXT,1,IOM)_$P(DDGLVID,DDGLDEL,10) ; I $D(DIWESUB) S DDWX=DIWESUB E I $D(DH)#2,$D(DIE) S DDWX=DH S DDWX=$E($G(DDWX),1,30) ; D CUP(0,1) W $TR($J("",IOM)," ","=") I DDWRAP S DX=2 X IOXY W "[ WRAP ]" S DX=12 X IOXY W "["_$$UP^DILIBF($P($$EZBLD^DIALOG(7002),U,$S(DDWREP:2,1:1)))_"]" ;**INSERT/REPLACE S DX=40-($L(DDWX)\2) X IOXY W "< "_$E(DDWX,1,30)_" >" N DDWH S DDWH="["_$$EZBLD^DIALOG(8074)_"]",DX=76-$L(DDWH) X IOXY W DDWH ;** ; D CUP(DDWMR+1,1) W $E(DDWRUL,1,IOM) I DDWLMAR-DDWOFS'<1,DDWLMAR-DDWOFS'>IOM D . S DX=DDWLMAR-DDWOFS-1 X IOXY W "<" I DDWRMAR-DDWOFS'<1,DDWRMAR-DDWOFS'>IOM D . S DX=DDWRMAR-DDWOFS-1 X IOXY W ">" Q ; AUTOTM ;Prompt for autosave time N DDWHLP,DDWANS,DDWCOD S DDWHLP(1)=" Enter the interval in MINUTES you wish to have the Screen Editor" S DDWHLP(2)=" automatically save the text. Enter a number between 0 and 120." S DDWHLP(3)=" A value of 0 means text is NOT automatically saved." D ASK^DDWG(5,"Interval in MINUTES to automatically save text: ",15,+$G(DDWAUTO),"D AUTOVAL^DDW1",.DDWHLP,.DDWANS,.DDWCOD) ; Q:DDWCOD="TO"!(DDWANS=U) I $G(DDWANS) D . S DDWAUTO=DDWANS . S DDWAUTO("H")=$H . S DDWAUTO("S")=DDWAUTO*60 E K DDWAUTO Q ; AUTOVAL ;Validate autosave time K DDWERR I DDWX?."^"!($P($G(DDWCOD),U)="TO") S DDWX=U Q I $L(DDWX)>15 D . S DDWERR=" Response must not be more than 15 characters in length." I DDWX'=+$P(DDWX,"E") D . S DDWERR=" Response must be numeric." I DDWX>120!(DDWX<0) D . S DDWERR=" Response must be between 0 and 120." Q ; AUTOSV ;Autosave I $D(DDWED) K DDWED D SV S DDWAUTO("H")=$H Q ; SV ;Called from DDWT1 and AUTOSV D SAVE S:DDWCNT<1 DDWCNT=1 I DDWRW+DDWA>DDWCNT D . D POS(DDWCNT-DDWA,"E","RN") E D POS(DDWRW,DDWC) Q ; SAVE ;Save document N DDWI,DDWLMEM,DDWLSTB,DDWX D MSG^DDW($$EZBLD^DIALOG(8075.5)) H .5 ;**'SAVING CHANGES' S DDWCNT=0 K @DDWDIC ; F DDWI=1:1:DDWA D . S DDWCNT=DDWCNT+1,DDWX=$$NTS(^TMP("DDW",$J,DDWI)) . I '$E(DDWBF,4) S @DDWDIC@(DDWCNT,0)=DDWX . E S @DDWDIC@(DDWCNT)=DDWX ; S DDWLMEM=999 F DDWI=1:1:DDWSTB+1 Q:DDWI>DDWSTB Q:^TMP("DDW1",$J,DDWI)'?." " I DDWI'>DDWSTB S DDWLSTB=DDWI E D . F DDWI=DDWMR:-1:0 Q:'DDWI Q:DDWL(DDWI)'?." " . S DDWLMEM=DDWI ; F DDWI=1:1:$$MIN(DDWLMEM,DDWMR) D . S DDWCNT=DDWCNT+1,DDWX=$$NTS(DDWL(DDWI)) . I '$E(DDWBF,4) S @DDWDIC@(DDWCNT,0)=DDWX . E S @DDWDIC@(DDWCNT)=DDWX ; I $D(DDWLSTB) F DDWI=DDWSTB:-1:DDWLSTB D . S DDWCNT=DDWCNT+1,DDWX=$$NTS(^TMP("DDW1",$J,DDWI)) . I '$E(DDWBF,4) S @DDWDIC@(DDWCNT,0)=DDWX . E S @DDWDIC@(DDWCNT)=DDWX ; S DWLC=DDWCNT,DWHD=U I DDWCNT,'$E(DDWBF,4) S @DDWDIC@(0)=U_U_DWLC_U_DWLC_U_DT_U D MSG^DDW() Q ; QUIT ;If any edits were made, issue confirmation prompt. S DDWFIN="" Q:$G(DDWFLAGS)["Q"!'$D(DDWED) ; N DDWHLP,DDWANS,DDWCOD S DDWHLP(1)=" Enter 'Yes' to save changes and quit." S DDWHLP(2)=" Enter 'No' to discard changes and quit." S DDWHLP(3)=" Enter '^' to return to the editor without saving or quitting." ; D ASK^DDWG(5,$$EZBLD^DIALOG(8075.1),3,"","D QUITVAL^DDW1",.DDWHLP,.DDWANS,.DDWCOD) ;**'DO YOU WANT TO SAVE CHANGES? ' ; I DDWCOD="TO"!(DDWANS=U) K DDWFIN E I DDWANS="Y" D SAVE K DUOUT ;GFT Q ; QUITVAL ;Validate responses to the confirmation prompt K DDWERR I DDWX[U!($P(DDWCOD,U)="TO") S DDWX=U Q I DDWX="" S DDWERR=$$EZBLD^DIALOG(8041) Q ;**'REQUIRED' ; S:DDWX?.E1L.E DDWX=$$UP^DILIBF(DDWX) ;** ; I $P("YES",DDWX)]"",$P("NO",DDWX)]"" D Q . S DDWERR=$$EZBLD^DIALOG(1401) ;**'NOT VALID' ; S DDWX=$E(DDWX) Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; CUP(Y,X) ;Cursor positioning S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; MIN(X,Y) ;Return the minimum of X and Y Q $S(X231 D ERR($$EZBLD^DIALOG(8138.2)) Q I DDWC'IOM D . D CUP(DDWMR+1,DDWLMAR-DDWOFS) W $E(DDWRUL,DDWLMAR) D CUP(DDWMR+1,DDWC-DDWOFS) W "<" D POS(DDWRW,DDWC) S DDWLMAR=DDWC Q ; RSET I 'DDWRAP D ERR($$EZBLD^DIALOG(8138.1)) Q I DDWC>245 D ERR($$EZBLD^DIALOG(8138.4)) Q I DDWC'>DDWLMAR D ERR($$EZBLD^DIALOG(8138.5)) Q I DDWRMAR-DDWOFS'<1,DDWRMAR-DDWOFS'>IOM D . D CUP(DDWMR+1,DDWRMAR-DDWOFS) W $E(DDWRUL,DDWRMAR) D CUP(DDWMR+1,DDWC-DDWOFS) W ">" D POS(DDWRW,DDWC) S DDWRMAR=DDWC Q ; WRAPM S DDWRAP=DDWRAP+1#2 D CUP(0,3) W $S(DDWRAP:"[ WRAP ]",1:"========") I 'DDWRAP D . S DDWLMAR(1)=DDWLMAR,DDWLMAR=1 . S DDWRMAR(1)=DDWRMAR,DDWRMAR=245 E D . S DDWLMAR=DDWLMAR(1) K DDWLMAR(1) . S DDWRMAR=DDWRMAR(1) K DDWRMAR(1) D RULER^DDW3,POS(DDWRW,DDWC) Q ; REPLM S DDWREP=DDWREP+1#2 D CUP(0,13) W "[",$$UP^DILIBF($P($$EZBLD^DIALOG(7002),U,$S(DDWREP:2,1:1))),"]" ;** D POS(DDWRW,DDWC) Q ; STAT S DDWSTAT=DDWSTAT+1#2 I DDWSTAT S DDWTO=1 E D . D CUP(DDWMR+2,1) . W $P(DDGLCLR,DDGLDEL) D POS(DDWRW,DDWC) . S DDWTO=DTIME . K DDWTC Q ; CUP(Y,X) ;Cursor positioning S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; SCR(C) ;Return screen number Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1 ; ERR(DDWX) ;Error W $C(7) D MSG^DDW(DDWX) H 2 D MSG^DDW() F R *DDWX:0 E Q D POS(DDWRW,DDWC) Q DDW3^INT^1^60300,29510^0 DDW3 ;SFISC/MKO-TOP, BOTTOM, SCROLL ;11:57 AM 24 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 ; TOP N DDWI I DDWA=0 D POS(1,1,"RN") Q D SHFTUP(1),POS(1,1,"RN") Q ; SHFTUP(DDWFL) ; N DDWSH,DDWI S DDWSH=DDWA+1-DDWFL D:DDWSH>DDWMR MSG^DDW(" ...") ;** ; F DDWI=DDWMR:-1:$$MAX(1,DDWMR-DDWSH+1) D:DDWI+DDWA'>DDWCNT . S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWI) . S ^TMP("DDW",$J,DDWA+DDWI)=DDWL(DDWI) ; I $E(DDWBF,2) F DDWI=DDWA:-1:DDWFL+DDWMR D . S DDWSTB=DDWSTB+1 . S ^TMP("DDW1",$J,DDWSTB)=^TMP("DDW",$J,DDWI) E S DDWSTB=$$MAX(DDWCNT-DDWFL+1-DDWMR,0) ; S DDWA=DDWFL-1 I DDWSH>DDWMR D . F DDWI=1:1:DDWMR S DDWL(DDWI)=^TMP("DDW",$J,DDWFL+DDWI-1) . I $P(DDWOFS,U,4)=1 D .. D CUP(1,1) .. F DDWI=1:1:DDWMR W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK))_$S(DDWIDDWMR MSG^DDW(" ...") ;** ; F DDWI=1:1:$$MIN(DDWSH,DDWMR) D . S DDWA=DDWA+1,^TMP("DDW",$J,DDWA)=DDWL(DDWI) . S ^TMP("DDW1",$J,DDWSTB+DDWMR-DDWI+1)=DDWL(DDWI) . ; I $E(DDWBF,3) F DDWI=DDWSTB:-1:DDWNSTB+1 D . S DDWA=DDWA+1 . S ^TMP("DDW",$J,DDWA)=^TMP("DDW1",$J,DDWI) E S DDWA=DDWFL-1 ; I DDWSH>DDWMR D . F DDWI=1:1:DDWMR S DDWL(DDWI)=$S(DDWNSTB-DDWI+1>0:^TMP("DDW1",$J,DDWNSTB-DDWI+1),1:"") . I $P(DDWOFS,U,4)=$$SCR($S($D(DDWCOL):DDWCOL,1:$L(DDWL(DDWMR))+1)) D .. D CUP(1,1) .. F DDWI=1:1:DDWMR W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK))_$S(DDWI0:^TMP("DDW1",$J,DDWNSTB-DDWI+1),1:"") . D:$P(DDWOFS,U,4)=$$SCR($L(DDWL(DDWMR))+1) SCRUP(DDWSH) ; S DDWSTB=$$MAX(0,DDWNSTB-DDWMR) S:'DDWSTB $E(DDWBF,3)=0 Q ; MVFWD(DDWNUM) ; N DDWI F DDWI=1:1:DDWNUM D . S DDWA=DDWA+1,^TMP("DDW",$J,DDWA)=DDWL(DDWI) . S ^TMP("DDW1",$J,DDWSTB+DDWMR-DDWI+1)=DDWL(DDWI) F DDWI=1:1:DDWMR-DDWNUM S DDWL(DDWI)=DDWL(DDWI+DDWNUM) F DDWI=DDWMR-DDWNUM+1:1:DDWMR D . S DDWL(DDWI)=^TMP("DDW1",$J,DDWSTB),DDWSTB=DDWSTB-1 D SCRUP(DDWNUM) Q ; SCRUP(DDWNUM) ; N DDWI D CUP(DDWMR,1) F DDWI=DDWMR-DDWNUM+1:1:DDWMR D . I $P(DDGLED,DDGLDEL,2)]"" W $C(10) . E D .. D CUP(1,1) W $P(DDGLED,DDGLDEL,4) .. D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,3) . I DDWL(DDWI)'?." " D .. D CUP(DDWMR,1) .. W $$LINE(DDWI,$G(DDWMARK)) D POS(DDWMR,DDWC,"RN") Q ; MVBCK(DDWNUM) ; N DDWI F DDWI=DDWMR:-1:DDWMR-DDWNUM+1 D:DDWI+DDWA'>DDWCNT . S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWI) . S ^TMP("DDW",$J,DDWA+DDWI)=DDWL(DDWI) F DDWI=DDWMR:-1:DDWNUM+1 S DDWL(DDWI)=DDWL(DDWI-DDWNUM) F DDWI=DDWNUM:-1:1 S DDWL(DDWI)=^TMP("DDW",$J,DDWA),DDWA=DDWA-1 D SCRDN(DDWNUM) Q ; SCRDN(DDWNUM) ; N DDWI D CUP(1,1) F DDWI=DDWNUM:-1:1 D . I $P(DDGLED,DDGLDEL,2)]"" W $P(DDGLED,DDGLDEL) . E D .. D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,4) .. D CUP(1,1) W $P(DDGLED,DDGLDEL,3) . I DDWL(DDWI)'?." " D .. D CUP(1,1) .. W $$LINE(DDWI,$G(DDWMARK)) D POS(1,DDWC,"RN") Q ; ERR ; W $C(7) Q ; CUP(Y,X) ; S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; SHIFT(C,DDWOFS) ; N DDWI,N,M,S S N=$P(DDWOFS,U,2),M=$P(DDWOFS,U,3) S S=$$SCR(C) S DDWOFS=S-1*M_U_N_U_M_U_S D RULER F DDWI=1:1:$$MIN(DDWMR,DDWCNT) D . S DY=IOTM+DDWI-2,DX=0 X IOXY . W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK)) Q ; RULER ;Write ruler D CUP(DDWMR+1,1) W $P(DDGLCLR,DDGLDEL)_$E(DDWRUL,1+DDWOFS,IOM+DDWOFS) I DDWLMAR-DDWOFS'<1,DDWLMAR-DDWOFS'>IOM D . D CUP(DDWMR+1,DDWLMAR-DDWOFS) W "<" I DDWRMAR-DDWOFS'<1,DDWRMAR-DDWOFS'>IOM D . D CUP(DDWMR+1,DDWRMAR-DDWOFS) W ">" Q ; LINE(DDWI,DDWMARK) ; N DDWX S DDWX=$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS) Q:$G(DDWMARK)="" DDWX ; N DDWR1,DDWC1,DDWR2,DDWC2 S DDWR1=$P(DDWMARK,U,1),DDWC1=$P(DDWMARK,U,2) S DDWR2=$P(DDWMARK,U,3),DDWC2=$P(DDWMARK,U,4) ; I DDWI'<(DDWR1-DDWA),DDWI'>(DDWR2-DDWA) D . N DDWX1,DDWX2 . S DDWX1=$S(DDWI=(DDWR1-DDWA):DDWC1,1:1) . S DDWX2=$S(DDWI=(DDWR2-DDWA):DDWC2,1:999) . S DDWX=$E(DDWL(DDWI),1+DDWOFS,DDWX1-1)_$P(DDGLVID,DDGLDEL,6)_$E(DDWL(DDWI),$$MAX(DDWX1,1+DDWOFS),$$MIN(DDWX2,IOM+DDWOFS))_$P(DDGLVID,DDGLDEL,10)_$E(DDWL(DDWI),$$MAX(DDWX2+1,1+DDWOFS),IOM+DDWOFS) Q DDWX ; SCR(C) ; Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1 ; MIN(X,Y) ; Q $S(XY:X,1:Y) DDW4^INT^1^60300,29510^0 DDW4 ;SFISC/PD KELTZ-OTHER NAVIGATION, DEL ;2:54 PM 23 Aug 2000 ;;22.0;VA FileMan;**18**;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; TAB N DDWX S DDWX=$F(DDWRUL,"T",DDWC+1) G:'DDWX ERR D POS(DDWRW,DDWX-1,"R") Q ; DEOL S (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1) W $P(DDGLCLR,DDGLDEL) Q ; DELW N DDWI,DDWW I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7 I DDWC>$L(DDWN) D Q . I DDWN?." " D .. D XLINE^DDW5() . E D .. N DDWY,DDWX .. S DDWY=DDWRW+DDWA,DDWX=DDWC .. D JOIN^DDW6 .. D POS(DDWY-DDWA,DDWX,"RN") ; S DDWI=$$WRPOS(DDWN) S DDWW=$E(DDWN,DDWC,DDWI-1) S $E(DDWN,DDWC,DDWI-1)="",DDWL(DDWRW)=DDWN I $P(DDGLED,DDGLDEL,6)]"" D . F DDWI=1:1:$L(DDWW) W $P(DDGLED,DDGLDEL,6) . S DDWI=$E(DDWN,IOM-$L(DDWW)+1+DDWOFS,IOM+DDWOFS) . I DDWI]"" D CUP(DDWRW,IOM-$L(DDWW)+1) W DDWI D CUP(DDWRW,DDWC-DDWOFS) E D . W $E(DDWN_$J("",$L(DDWW)),DDWC,IOM+DDWOFS) . D CUP(DDWRW,DDWC-DDWOFS) Q ; WORDR N DDWI S DDWI=$$WRPOS(DDWN) D POS(DDWRW,DDWI,"R") Q ; WRPOS(DDWT) ; N DDWP,DDWS S DDWT=$$PUNC(DDWT) S DDWS=$F(DDWT," ",DDWC+1),DDWP=$F(DDWT,"!",DDWC+1) S:'DDWS DDWS=999 S:'DDWP DDWP=999 ; I DDWC>$L(DDWT) D . I DDWRW+DDWA'1 D . D POS(1,DDWC,"RN") E D . S DDWX=$$MIN(DDWA,DDWMR) . D:DDWX MVBCK^DDW3(DDWX) Q ; JLEFT I DDWC=1,'DDWOFS Q N DDWX I DDWN?." " S DDWX=1 E F DDWX=1:1:$L(DDWN) Q:$E(DDWN,DDWX)'=" " I DDWC-DDWOFS=1,DDWC>1 D POS(DDWRW,DDWC-1,"R") Q:DDWC=DDWX S DDWC=$$MAX($S($$SCR(DDWX)=$$SCR(DDWC)&(DDWC'=DDWX):DDWX,1:0),1+DDWOFS) D POS(DDWRW,DDWC,"R") Q JRIGHT N DDWX S DDWX=$L(DDWN)+1 I DDWC-DDWOFS=IOM,DDWC<246 D POS(DDWRW,DDWC+1,"R") Q:DDWC=DDWX S DDWC=$$MIN($S($$SCR(DDWX)=$$SCR(DDWC)&(DDWC'=DDWX):DDWX,1:999),$$MIN(IOM+DDWOFS,246)) D POS(DDWRW,DDWC,"R") Q ; LBEG N DDWX I DDWN?." " D POS(DDWRW,1,"R") Q I $E(DDWN,1,DDWC-1)?." ",$E(DDWN,DDWC)'=" " D POS(DDWRW,1,"R") Q F DDWX=1:1:$L(DDWN) Q:$E(DDWN,DDWX)'=" " D POS(DDWRW,DDWX,"R") Q LEND D POS(DDWRW,"E","R") Q ; ERR ;Beep W $C(7) Q ; CUP(Y,X) ;Cursor positioning S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; SCR(C) ;Screen # Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1 ; MIN(X,Y) ; Q $S(XY:X,1:Y) PUNC(X) ; Q $TR(X,"`~!@#$%^&*()-_=+\|[{]};:'"",<.>/?",$TR($J("",32)," ","!")) DDW5^INT^1^60300,29510^0 DDW5 ;SFISC/PD KELTZ-WRAP, BREAK, ILINE, XLINE ;01:23 PM 21 Dec 1994 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; WRAP ;Wrap at word boundary S:$E(DDWN,DDWC,999)?1." " (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1) I DDWC'>$L(DDWN) D WRAPI Q I 'DDWRAP D POS(DDWRW,DDWRMAR+1,"R"),BREAK(1) Q D WRAPW Q ; WRAPI ;Cursor in middle I $E(DDWN,DDWLMAR,999)'[" "!'DDWRAP D BREAK(-1),POS(DDWRW-1,"E","RN") Q N DDWCSV,DDWI,DDWLST,DDWRMSV S DDWI=$F(DDWN," ",DDWC) I DDWI,DDWI-2'>DDWRMAR D . S DDWCSV=DDWC . S (DDWN,DDWL(DDWRW))=$$TR(DDWN) . D POS(DDWRW,DDWI,"R"),BREAK(-1),POS(DDWRW-1,DDWCSV,"RN") . S (DDWN,DDWL(DDWRW))=$$TR(DDWN) E I DDWC=2 D . D POS(DDWRW,DDWRMAR+1,"R"),BREAK(-1),POS(DDWRW-1,2,"RN") E D . S DDWLST=$$TR($E(DDWN,DDWC,999)) . S (DDWL(DDWRW),DDWN)=$E(DDWN,1,DDWC-1) . S DDWRMSV=DDWRMAR,DDWRMAR=$$MIN(DDWRMAR,DDWC-2) . D WRAPW . W $E(DDWLST,1,IOM+DDWOFS-DDWC) . S DDWL(DDWRW)=DDWN_DDWLST,DDWRMAR=DDWRMSV . D POS(DDWRW,DDWC,"RN") Q ; WRAPW ;Cursor at end N DDWI,DDWS1,DDWS2,DDWTXT S DDWTXT(1)=DDWN D ADJMAR^DDW6(.DDWTXT,"","I") ; S DDWS1=$$SCR($L(DDWTXT(1))+1),DDWS2=$$SCR($L(DDWTXT(DDWTXT))+1) I DDWS1=$P(DDWOFS,U,4),DDWS2=$P(DDWOFS,U,4),DDWTXT=2 D . S (DDWN,DDWL(DDWRW))=DDWTXT(1)_DDWTXT(2) . S DDWC=$L(DDWTXT(1))+1 . D POS(DDWRW,DDWC),BREAK(1) ; E D . F DDWI=1:1:DDWTXT-1 D .. S (DDWN,DDWL(DDWRW))=DDWTXT(DDWI) .. D ILINE .. S (DDWN,DDWL(DDWRW))=DDWTXT(DDWI+1) .. I DDWS2=$P(DDWOFS,U,4) D ... D CUP(DDWRW-1,1) ... W $P(DDGLCLR,DDGLDEL)_$E(DDWTXT(DDWI),1+DDWOFS,IOM+DDWOFS) ... D CUP(DDWRW,1) W $E(DDWN,1+DDWOFS,IOM+DDWOFS) . D POS(DDWRW,"E","R") Q ; BREAK(DDWFLAG) ;Break line, make new line current ;Final cursor position: ; 0:lmar of new line (used by ) ; 1:end of new line (used by Wrap) ;-1:doesn't matter (used by Wrap) N DDWRST I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7 S DDWRST=$E(DDWN,DDWC,999) I DDWLMAR>1,DDWRST'?@(DDWLMAR-1_""" "".E") D . S DDWRST=$J("",DDWLMAR-1)_$$LD(DDWRST) S (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1) W $P(DDGLCLR,DDGLDEL) D ILINE S (DDWN,DDWL(DDWRW))=DDWRST ; I $G(DDWFLAG)=1 D . I $$SCR($L(DDWN)+1)=$P(DDWOFS,U,4) D .. D CUP(DDWRW,1) W $E(DDWN,1+DDWOFS,IOM+DDWOFS) . D POS(DDWRW,"E","R") ; E I '$G(DDWFLAG) D . I $P(DDWOFS,U,4)=1 D CUP(DDWRW,1) W $E(DDWN,1,IOM) . D POS(DDWRW,DDWLMAR,"R") ; E D CUP(DDWRW,1) W $E(DDWN,1+DDWOFS,IOM+DDWOFS) Q ; ILINE ;Insert line below current line, make that current ;Column is unchanged N DDWI,DDWX I DDWRWDDWCNT D .. S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWMR) . F DDWI=DDWMR:-1:DDWRW+2 S DDWL(DDWI)=DDWL(DDWI-1) . S DDWL(DDWRW+1)="" . D CUP(DDWRW+1,1) . ; . I $P(DDGLED,DDGLDEL,3)]"" D .. I $P(DDGLED,DDGLDEL,2)="" D ... D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,4) D CUP(DDWRW+1,1) .. W $P(DDGLED,DDGLDEL,3) . E D .. S DDWX=IOTM .. S IOTM=IOTM+DDWRW W @$P(DDGLED,DDGLDEL,2) S IOTM=DDWX .. D CUP(DDWRW+1,1) W $P(DDGLED,DDGLDEL) .. W @$P(DDGLED,DDGLDEL,2) . D POS(DDWRW+1,DDWC,"RN") ; E D . S DDWA=DDWA+1,^TMP("DDW",$J,DDWA)=DDWL(1) . F DDWI=1:1:DDWMR-1 S DDWL(DDWI)=DDWL(DDWI+1) . S DDWL(DDWMR)="" . D SCRUP^DDW3(1) S DDWCNT=DDWCNT+1 S $E(DDWBF,1,3)=111 Q ; XLINE(DDWFLAG,DDWNP) ;Delete current line ;DDWFLAG: ; 1:leave cursor on deleted line (used by Join) ; 0:move cursor up one line if deleted line is last line ; (used by PF1-D and DELBLK) ; DDWNP = 1:don't bother printing, used by DELBLK N DDWI,DDWX I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7 F DDWI=DDWRW:1:DDWMR-1 S DDWL(DDWI)=DDWL(DDWI+1) S DDWX="" S:DDWSTB DDWX=^TMP("DDW1",$J,DDWSTB),DDWSTB=DDWSTB-1 S DDWL(DDWMR)=DDWX ; D:'$G(DDWNP) XLINEP ; S DDWCNT=DDWCNT-1 I 'DDWCNT D . S DDWCNT=1 D POS(1,DDWLMAR,"RN") E I DDWA+DDWRW>DDWCNT,'$G(DDWFLAG) D . D UP^DDWT1 E D POS(DDWRW,DDWC,"N") S $E(DDWBF,1,3)=111 Q ; XLINEP ;Redisplay screen I $P(DDGLED,DDGLDEL,4)]"" D . W $P(DDGLED,DDGLDEL,4) . I $P(DDGLED,DDGLDEL,2)="" D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,3) E I DDWRWIOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; SCR(C) ; Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1 ; MIN(X,Y) ; Q $S(X$P(DDWMARK,U,3) D UNMARK^DDW7 D POS(DDWRW,DDWLMAR,"R") S DDWRFMT=0 F D JOIN Q:DDWRFMT Q ; JOIN ;Join N DDWI,DDWSCR,DDWNSV,DDWLL,DDWTXT,DDWTXT0 I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7 ; ;Get current line S (DDWTXT(1),DDWNSV)=DDWN ; ;Get next line I DDWRW=DDWMR S:DDWSTB DDWTXT(2)=^TMP("DDW1",$J,DDWSTB) E S:DDWA+DDWRWDDWRMAR S:$D(DDWTXT(2))#2 DDWLL=DDWTXT(2) . E I $D(DDWRFMT) S DDWRFMT=1 ; ;Adjust S DDWTXT0=$O(DDWTXT(""),-1) D ADJMAR(.DDWTXT,"","I") S:$D(DDWLL) DDWTXT=DDWTXT+1,DDWTXT(DDWTXT)=DDWLL S (DDWN,DDWL(DDWRW))=DDWTXT(1) ; ;Delete next line I DDWTXT0>1,DDWTXT=1 D . I DDWRW=DDWMR S DDWSTB=DDWSTB-1,DDWCNT=DDWCNT-1,$E(DDWBF,1,3)=111 . E D POS(DDWRW+1,DDWC,"RN"),XLINE^DDW5(1),POS(DDWRW-1,DDWC,"RN") ; ;DDWSCR: curr scr = final scr I DDWTXT=1,'$D(DDWRFMT) S DDWSCR=$L(DDWTXT(1))+1-DDWOFS E S DDWSCR=DDWLMAR-DDWOFS S DDWSCR=DDWSCR'<1&(DDWSCR'>IOM) ; I DDWSCR,DDWNSV'=DDWN D . I DDWNSV]"",$P(DDWNSV,DDWN)="" D .. D CUP(DDWRW,$$MAX($L(DDWN)+1-DDWOFS,1)) .. W $P(DDGLCLR,DDGLDEL) . E I DDWN]"",$P(DDWN,DDWNSV)="" D .. D CUP(DDWRW,$$MAX($L(DDWNSV)+1-DDWOFS,1)) .. W $E(DDWN,$$MAX($L(DDWNSV),DDWOFS)+1,IOM+DDWOFS) . E D .. D CUP(DDWRW,DDWOFS+1) .. W $P(DDGLCLR,DDGLDEL)_$E(DDWN,DDWOFS+1,IOM+DDWOFS) ; I DDWTXT=1 D . I '$D(DDWRFMT) D .. D POS(DDWRW,"E","RN") . E D POS(DDWRW,DDWLMAR,"RN") E D JOIN2 Q ; JOIN2 ;Join produced >1 lines D POS(DDWRW,DDWLMAR,"R") ; I DDWTXT0=2 D . I DDWRW1 F DDWJ=$G(DDWFLG)["I"+1:1:DDWT D . S DDWT(DDWJ)=$J("",DDWLMAR-1)_DDWT(DDWJ) Q ; AMLOOP ;Process DDWT(DDWJ) I $E(DDWT(DDWJ),1,DDWW)=$J("",DDWW) S DDWT(DDWJ)=$$LD(DDWT(DDWJ)) ; E I $L(DDWT(DDWJ))>DDWW F D Q:$L(DDWT(DDWJ))'>DDWW . N DDWK,DDWFST,DDWLST . F DDWK=$O(DDWT(""),-1)+1:-1:DDWJ+2 S DDWT(DDWK)=DDWT(DDWK-1) . D SLICE(DDWT(DDWJ),DDWW,.DDWFST,.DDWLST) . S DDWT(DDWJ)=DDWFST,DDWT(DDWJ+1)=DDWLST . D AMINCJ ; E I $L(DDWT(DDWJ))=DDWW!'$D(DDWT(DDWJ+1)) D . I DDWRAP,$D(DDWT(DDWJ+1)) S DDWT(DDWJ+1)=$$LD(DDWT(DDWJ+1)) . D AMINCJ ; E I 'DDWRAP D . N DDWK S DDWK=DDWW-$L(DDWT(DDWJ)) . S DDWT(DDWJ)=DDWT(DDWJ)_$E(DDWT(DDWJ+1),1,DDWK) . S DDWT(DDWJ+1)=$E(DDWT(DDWJ+1),DDWK+1,999) . D:DDWT(DDWJ+1)="" AMSHIFT(.DDWT,DDWJ+1) ; E D . N DDWD,DDWI,DDWNXT,DDWSP,DDWX1,DDWX2 . S DDWD=0 F D Q:DDWD .. S DDWX1=DDWT(DDWJ),(DDWX2,DDWT(DDWJ+1))=$$LD(DDWT(DDWJ+1)) .. I DDWX2="" S DDWD=1 Q .. S DDWNXT=$P(DDWX2," "),DDWI=$L(DDWNXT) .. I $E(DDWX2,DDWI+2)=" ",$E(DDWX2,DDWI+3,999)'?." " D ... F DDWI=DDWI+2:1 Q:$E(DDWX2,DDWI+1)'=" " .. S DDWSP=DDWX1'?.E1" " .. I $L(DDWX1)+DDWSP+$L($E(DDWX2,1,DDWI))>DDWW S DDWD=1 Q .. S DDWT(DDWJ)=DDWX1_$E(" ",DDWSP)_$E(DDWX2,1,DDWI) .. S DDWT(DDWJ+1)=$$LD($E(DDWX2,DDWI+1,999)) . ; . I DDWT(DDWJ+1)="" D .. D AMSHIFT(.DDWT,DDWJ+1) . E D AMINCJ Q ; AMSHIFT(DDWT,DDWJ) ;Delete DDWT(DDWJ) and shift up N DDWI F DDWI=DDWJ:1:$O(DDWT(""),-1)-1 S DDWT(DDWI)=DDWT(DDWI+1) K DDWT($O(DDWT(""),-1)) Q ; AMINCJ ;Incr DDWJ I DDWJ=1,$G(DDWFLG)["I" S DDWW=DDWRMAR-DDWLMAR+1 S DDWJ=DDWJ+1 Q ; SLICE(DDWN,DDWW,DDWFST,DDWRST) ; ;Out: DDWFST=first part of text, $L<=DDWRMAR ; DDWRST=remaining part (lead blanks removed) N DDWI,DDWP,DDWX S:'$G(DDWW) DDWW=DDWRMAR I 'DDWRAP S DDWFST=$E(DDWN,1,DDWW),DDWLST=$E(DDWN,DDWW+1,999) Q ; ;Set DDWI to column # at which to break S DDWX=$E(DDWN,1,DDWW),DDWI=DDWW I DDWX'[" " E I DDWX?." " E I $E(DDWX,DDWW)=" ",$E(DDWN,DDWW+1)'=" " E D . F DDWP=$L(DDWX," "):-1:0 Q:$P(DDWX," ",DDWP)]"" . Q:DDWP=1 . S DDWI=$L($P(DDWX," ",1,DDWP-1))+1 . S:DDWI'>$S(DDWW=DDWRMAR:DDWLMAR,1:1) DDWI=DDWW ; S DDWFST=$E(DDWN,1,DDWI),DDWRST=$$LD($E(DDWN,DDWI+1,999)) Q ; TR(X) Q:$G(X)="" X N I F I=$L(X):-1:0 Q:$E(X,I)'=" " Q $E(X,1,I) ; LD(X) Q:$G(X)="" X N I F I=1:1:$L(X)+1 Q:$E(X,I)'=" " Q $E(X,I,999) ; CUP(Y,X) ; S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; SCR(C) ;Screen number Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1 ; MIN(X,Y) ; Q $S(XY:X,1:Y) DDW7^INT^1^60300,29510^0 DDW7 ;SFISC/MKO-MARK TEXT ;2:30 PM 27 Jul 2000 ;;22.0;VA FileMan;**18**;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; MARK ;Mark the text I $D(DDWMARK) D . D BOUND E D . S DDWMARK=DDWA+DDWRW_U_DDWC_U_(DDWA+DDWRW)_U_$$MAX(DDWC,$L(DDWN)) . D PAINT(DDWMARK,1),IND(1) Q ; BOUND ;Mark ending boundary, highlight selected text N DDWI,DDWX,DDWY ; S DDWI=DDWA+DDWRW_U_DDWC S DDWX=$P(DDWMARK,U,1,2) S DDWY=$P(DDWMARK,U,3,4) ; I $$ISLESS(DDWI,DDWX) D . D PAINT(DDWX_U_DDWY) . D PAINT(DDWI_U_DDWX,1) . S DDWMARK=DDWI_U_DDWX E D . I $$ISLESS(DDWI,DDWY) D .. D PAINT(DDWI_U_DDWY),PAINT(DDWI_U_DDWI,1) . E D PAINT(DDWY_U_DDWI,1) . S DDWMARK=DDWX_U_DDWI D CUP(DDWRW,DDWC-DDWOFS) Q ; UNMARK ;Unmark the text D:$D(DDWMARK) PAINT(DDWMARK),IND() K DDWMARK Q ; PAINT(DDWMARK,DDWREV) ;Paint selected text N DDWI,DDWE1,DDWE2,DDWL1,DDWL2,DDWR1,DDWC1,DDWR2,DDWC2 S DDWR1=$P(DDWMARK,U,1),DDWC1=$P(DDWMARK,U,2) S DDWR2=$P(DDWMARK,U,3),DDWC2=$P(DDWMARK,U,4) S DDWL1=$$MAX(DDWR1-DDWA,1),DDWL2=$$MIN(DDWR2-DDWA,DDWMR) Q:DDWL1>DDWL2 ; W:$G(DDWREV) $P(DDGLVID,DDGLDEL,6) F DDWI=DDWL1:1:DDWL2 D . S DDWE1=$$MAX($S(DDWI+DDWA=DDWR1:DDWC1,1:1),DDWOFS+1) . S DDWE2=$$MIN($S(DDWI+DDWA=DDWR2:DDWC2,1:999),IOM+DDWOFS) . Q:DDWE1>DDWE2 . D CUP(DDWI,DDWE1-DDWOFS) . W $E(DDWL(DDWI),DDWE1,DDWE2) W:$G(DDWREV) $P(DDGLVID,DDGLDEL,10) Q ; IND(DDWX) ;Paint indicator S DY=$G(DDWBM,IOSL)-1,DX=IOM-7 X IOXY W $S($G(DDWX):$P(DDGLVID,DDGLDEL,6)_"Select"_$P(DDGLVID,DDGLDEL,10),1:$P(DDGLCLR,DDGLDEL)) D CUP(DDWRW,DDWC-DDWOFS) Q ; CUP(Y,X) ; S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; ISLESS(X,Y) ;Is coordinate X less than coordinate Y N R1,C1,R2,C2 S R1=$P(X,U),C1=$P(X,U,2) S R2=$P(Y,U),C2=$P(Y,U,2) ; Q:R1>R2 0 Q:R1C2 0 Q 1 ; MIN(X,Y) ; Q $S(XY:X,1:Y) DDW8^INT^1^60300,29510^0 DDW8 ;SFISC/MKO-COPY, CUT, PASTE ;12:09 PM 24 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 ; CUT() ;Cut selected text N DDWADJ,DDWC1,DDWC2,DDWCSV,DDWISIN,DDWNDEL,DDWR1,DDWR2,DDWRSV I '$D(DDWMARK) D ERR($$EZBLD^DIALOG(1404)) Q ;**'NO TEXT' ; S DDWED=1 S DDWISIN=$$ISINSEL() D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2) D COPYBUF ; S DDWRSV=DDWRW,DDWCSV=DDWC I DDWR2>DDWA,DDWR2-DDWADDWMR,DDWR1-DDWA>DDWRW S DDWADJ=0 ; D DELBLK^DDW9(.DDWNDEL) D:$D(DDWADJ) POS(DDWRSV-(DDWADJ*DDWNDEL),DDWCSV,"RN") D:'DDWISIN PASTE() Q ; COPY() ;Copy selected text N DDWC1,DDWC2,DDWISIN,DDWR1,DDWR2 I '$D(DDWMARK) D ERR($$EZBLD^DIALOG(1404)) Q ;**'NO TEXT' ; S DDWISIN=$$ISINSEL() D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2) D COPYBUF D UNMARK^DDW7 D:'DDWISIN PASTE() Q ; COPYBUF ;Copy selected text to buffer N DDWND,DDWI,DDWX,DDWX1,DDWX2 K ^TMP("DDWB",$J) S DDWND=0 ; D:DDWR2-DDWR1>50 MSG^DDW(" ...") ;** ; F DDWI=DDWR1:1:$$MIN(DDWA,DDWR2) D . S DDWND=DDWND+1 . S DDWX=^TMP("DDW",$J,DDWI) . S DDWX=$E(DDWX,$S(DDWI=DDWR1:DDWC1,1:1),$S(DDWI=DDWR2:DDWC2,1:999)) . S ^TMP("DDWB",$J,DDWND)=DDWX ; F DDWI=$$MAX(DDWR1-DDWA,1):1:$$MIN(DDWR2-DDWA,DDWMR) D . S DDWX=$E(DDWL(DDWI),$S(DDWI+DDWA=DDWR1:DDWC1,1:1),$S(DDWI+DDWA=DDWR2:DDWC2,1:999)) . S DDWND=DDWND+1 . S ^TMP("DDWB",$J,DDWND)=DDWX ; S DDWX1=$$RTOSTB(DDWR1),DDWX2=$$RTOSTB(DDWR2) F DDWI=$$MIN(DDWSTB,DDWX1):-1:DDWX2 D . S DDWND=DDWND+1 . S DDWX=^TMP("DDW1",$J,DDWI) . S DDWX=$E(DDWX,$S(DDWI=DDWX1:DDWC1,1:1),$S(DDWI=DDWX2:DDWC2,1:999)) . S ^TMP("DDWB",$J,DDWND)=DDWX ; D:DDWR2-DDWR1>50 MSG^DDW() Q ; PASTE() ;Paste text I $D(DDWMARK) D ERR("You curently have text selected.") Q I '$D(^TMP("DDWB",$J)) D ERR($$EZBLD^DIALOG(1404)) Q ;** ; S DDWED=1 N DDWBSIZ,DDWFC,DDWI,DDWLST,DDWNSV,DDWTXT,DDWX S DDWBSIZ=$O(^TMP("DDWB",$J,""),-1) ; S DDWTXT=1 S:$L(DDWN)+1IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; ISINSEL() ;Is the cursor within the selected text N DDWI,DDWY S DDWI=DDWRW+DDWA,DDWY=0 I DDWI<$P(DDWMARK,U) E I DDWI>$P(DDWMARK,U,3) E I DDWI=$P(DDWMARK,U),DDWC<$P(DDWMARK,U,2) E I DDWI=$P(DDWMARK,U,3),DDWC-1>$P(DDWMARK,U,4) E S DDWY=1 Q DDWY ; PMARK(M,R1,C1,R2,C2) ;Parse M (DDWMARK) S R1=$P(M,U),C1=$P(M,U,2) S R2=$P(M,U,3),C2=$P(M,U,4) Q ; ERR(DDWX) ; D MSG^DDW($C(7)_DDWX) H 2 D MSG^DDW() D CUP(DDWRW,DDWC-DDWOFS) F R *DDWX:0 E Q Q ; TR(X) ;Strip trailing blanks Q:$G(X)="" X N I F I=$L(X):-1:0 Q:$E(X,I)'=" " Q $E(X,1,I) ; LD(X) ;Strip leading blanks Q:$G(X)="" X N I F I=1:1:$L(X)+1 Q:$E(X,I)'=" " Q $E(X,I,999) ; RTOSTB(R) ;Return node in STB given line # Q DDWSTB+DDWA+DDWMR+1-R ; SCR(C) ;Return screen number Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1 ; MIN(X,Y) ; Q $S(XY:X,1:Y) DDW9^INT^1^60300,29510^0 DDW9 ;SFISC/MKO-MARK TEXT ;12:20 PM 24 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 ; CHKDEL(DDWY) ;Check that cursor is on block and delete N DDWI N DDWC1,DDWC2,DDWR1,DDWR2,DDWI D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2) S DDWY=0,DDWI=DDWRW+DDWA Q:DDWIDDWR2 I DDWI=DDWR1,DDWCDDWC2 D UNMARK^DDW7 Q ; D DELBLK() S DDWY=1 Q ; DELBLK(DDWNDEL) ;Delete block ;Returns: DDWNDEL=# lines deleted from the screen N DDWNP,DDWI,DDWX I '$D(DDWR1) N DDWR1,DDWR2,DDWC1,DDWC2 D . D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2) ; S DDWNDEL=0,$E(DDWBF,1,3)=111 K DDWMARK ; I DDWR2-DDWA<1 D . D DELABV E I DDWR1-DDWA>DDWMR D . D DELBEL E D DELMID ; D IND^DDW7() Q ; DELABV ;All of the block is above the screen I DDWR1=DDWR2 D Q . N DDWX . S DDWX=^TMP("DDW",$J,DDWR1),$E(DDWX,DDWC1,DDWC2)="" . I DDWX]"" S ^TMP("DDW",$J,DDWR1)=DDWX . E D SHIFTA(DDWR1,DDWR1) ; D:DDWR2-DDWR1>50 MSG^DDW(" ...") ;** N DDWFST,DDWLST S DDWFST=$E(^TMP("DDW",$J,DDWR1),1,DDWC1-1) S DDWLST=$E(^TMP("DDW",$J,DDWR2),DDWC2+1,999) I DDWFST]"" S ^TMP("DDW",$J,DDWR1)=DDWFST,DDWFST=DDWR1+1 E S DDWFST=DDWR1 I DDWLST]"" S ^TMP("DDW",$J,DDWR2)=DDWLST,DDWLST=DDWR2-1 E S DDWLST=DDWR2 D SHIFTA(DDWFST,DDWLST) D:DDWR2-DDWR1>50 MSG^DDW() Q ; SHIFTA(DDWA1,DDWA2) ; N DDWNL S DDWNL=DDWA2-DDWA1+1 I DDWA2=DDWA S DDWA=DDWA-DDWNL,DDWCNT=DDWCNT-DDWNL Q ; N DDWI F DDWI=DDWA1:1:DDWA-DDWNL S ^TMP("DDW",$J,DDWI)=^TMP("DDW",$J,DDWI+DDWNL) S DDWA=DDWA-DDWNL,DDWCNT=DDWCNT-DDWNL Q ; DELBEL ;All of the block is below the screen N DDWS1,DDWS2 S DDWS1=DDWA+DDWMR+DDWSTB-DDWR1+1,DDWS2=DDWA+DDWMR+DDWSTB-DDWR2+1 I DDWS1=DDWS2 D Q . N DDWX . S DDWX=^TMP("DDW1",$J,DDWS1),$E(DDWX,DDWC1,DDWC2)="" . I DDWX]"" S ^TMP("DDW1",$J,DDWS1)=DDWX . E D SHIFTB(DDWS1,DDWS1) ; D:DDWR2-DDWR1>50 MSG^DDW(" ...") ;** N DDWFST,DDWLST S DDWFST=$E(^TMP("DDW1",$J,DDWS1),1,DDWC1-1) S DDWLST=$E(^TMP("DDW1",$J,DDWS2),DDWC2+1,999) I DDWFST]"" S ^TMP("DDW1",$J,DDWS1)=DDWFST,DDWFST=DDWS1-1 E S DDWFST=DDWS1 I DDWLST]"" S ^TMP("DDW1",$J,DDWS2)=DDWLST,DDWLST=DDWS2+1 E S DDWLST=DDWS2 D SHIFTB(DDWFST,DDWLST) D:DDWR2-DDWR1>50 MSG^DDW() Q ; SHIFTB(DDWS1,DDWS2) ; N DDWNL S DDWNL=DDWS1-DDWS2+1 I DDWS1=DDWSTB S DDWSTB=DDWSTB-DDWNL,DDWCNT=DDWCNT-DDWNL Q ; N DDWI F DDWI=DDWS2:1:DDWSTB-DDWNL S ^TMP("DDW1",$J,DDWI)=^TMP("DDW1",$J,DDWI+DDWNL) S DDWSTB=DDWSTB-DDWNL,DDWCNT=DDWCNT-DDWNL Q ; DELMID ;A portion of the block appears on the screen I DDWR2-1-DDWA>DDWMR D . S DDWX=DDWR2-(DDWA+DDWMR+1) . S DDWSTB=DDWSTB-DDWX,DDWCNT=DDWCNT-DDWX ; I DDWR2-DDWA>DDWMR D . S DDWX=$E(^TMP("DDW1",$J,DDWSTB),DDWC2+1,999) . I DDWX="" S DDWSTB=DDWSTB-1,DDWCNT=DDWCNT-1 . E S ^TMP("DDW1",$J,DDWSTB)=DDWX ; D POS($$MAX(DDWR1-DDWA,1),$S(DDWR1=DDWR2:DDWC1,1:1),"RN") ; S DDWNP=DDWR2-DDWA'DDWA D . S DDWX=DDWA-DDWR1 . S DDWA=DDWA-DDWX,DDWCNT=DDWCNT-DDWX ; I DDWR1'>DDWA D . S DDWX=$E(^TMP("DDW",$J,DDWA),1,DDWC1-1) . I DDWX="" S DDWA=DDWA-1,DDWCNT=DDWCNT-1 . E S ^TMP("DDW",$J,DDWA)=DDWX ; S:DDWCNT<1 DDWCNT=1 D:DDWRW+DDWA>DDWCNT UP^DDWT1 Q ; PMARK(M,R1,C1,R2,C2) ;Parse M (DDWMARK) S R1=$P(M,U),C1=$P(M,U,2) S R2=$P(M,U,3),C2=$P(M,U,4) Q ; CUP(Y,X) ; S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; MIN(X,Y) ; Q $S(XY:X,1:Y) DDWC^INT^1^60300,29510^0 DDWC ;SFISC/MKO-CHANGE (REPLACE) ;02:24 PM 14 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 CHG ;Change N DDWOPT D SETUP^DDWC1 F D PROC Q:DDWOPT=-1 D RESTORE^DDWC1 K DDWCHG(1) Q ; PROC ;Main procedure N DDWCOD,DDWT ; D:$D(DDWMARK) UNMARK^DDW7 D EN^DIR0(IOTM+DDWMR,14,30,"",$G(DDWFIND),100,"","","AKTW",.DDWT,.DDWCOD) I DDWT=""!($P(DDWCOD,U)="TO") S DDWOPT=-1 Q S DDWFIND=DDWT,DDWT=$$UC(DDWT) ; K DDWCHG(1) D EN^DIR0(IOTM+DDWMR+1,14,30,"",$G(DDWCHG),100,"","","AKTW",.DDWCHG,.DDWCOD) I $P(DDWCOD,U)="TO" S DDWOPT=-1 Q S:DDWCHG?1L.E DDWCHG(1)=$$UC($E(DDWCHG))_$E(DDWCHG,2,999) ; F D OPT Q:DDWOPT]"" Q ; OPT ;Prompt for and process option W $P(DDGLVID,DDGLDEL,6) F D Q:DDWOPT]"" . D CUP(DDWMR+4,15) W " "_$C(8) . R DDWOPT#1:DTIME E S DDWOPT="Q" Q . I DDWOPT=U S DDWOPT="Q" . I DDWOPT="" S DDWOPT="E" Q . I DDWOPT="?" S DDWOPT="H" Q . S DDWOPT=$$UC(DDWOPT) . I "^F^R^A^Q^"'[(U_DDWOPT_U) W $C(7) S DDWOPT="" D CUP(DDWMR+4,15) W $P(DDGLVID,DDGLDEL,10)_" " D @DDWOPT Q ; F ;Find next D FINDT^DDWF(DDWFIND) S DDWOPT="" Q ; R ;Replace N DDWE I '$D(DDWMARK) D CERR Q D RS(.DDWE) Q:$G(DDWE) D F Q ; RS(DDWE) ;Change selected text N DDWDIF S DDWDIF=$L(DDWCHG)-$P(DDWMARK,U,4)+$P(DDWMARK,U,2)-1 I $L(DDWN)+DDWDIF>245 D Q . S DDWE=1,DDWOPT="" . D MSG($C(7)_$$EZBLD^DIALOG(347)) ;**TOO LONG ; S DDWE=0,DDWED=1 S $E(DDWN,$P(DDWMARK,U,2),$P(DDWMARK,U,4))=$S($E(DDWN,$P(DDWMARK,U,2))?1U:$G(DDWCHG(1),DDWCHG),1:DDWCHG) S DDWL(DDWRW)=DDWN D CUP(DDWRW,1) W $P(DDGLCLR,DDGLDEL)_$E(DDWN,1+DDWOFS,IOM+DDWOFS) K DDWMARK D IND^DDW7() D POS(DDWRW,DDWC+DDWDIF,"R") Q ; A ;Change all N DDWE,DDWF,DDWI,DDWND,DDWX D MSG^DDW("...") ;**'CHANGING TEXT' I $D(DDWMARK) D RS(.DDWE) G:$G(DDWE) AEND ; S DDWX=$F($$UC(DDWL(DDWRW)),DDWT,DDWC) I DDWX D . S DDWL(DDWRW)=$$REP(DDWL(DDWRW),DDWFIND,.DDWCHG,DDWX,.DDWE),DDWF=1 . S:$G(DDWE) DDWE=DDWRW+DDWA_U_DDWE ; I '$G(DDWE) F DDWI=DDWRW+1:1:DDWMR D Q:$G(DDWE) . S DDWX=$F($$UC(DDWL(DDWI)),DDWT) . S:DDWX DDWL(DDWI)=$$REP(DDWL(DDWI),DDWFIND,.DDWCHG,DDWX,.DDWE),DDWF=1 . S:$G(DDWE) DDWE=DDWI+DDWA_U_DDWE ; I '$G(DDWE) F DDWI=DDWSTB:-1:1 D Q:$G(DDWE) . S DDWND=^TMP("DDW1",$J,DDWI) . S DDWX=$F($$UC(DDWND),DDWT) . S:DDWX ^TMP("DDW1",$J,DDWI)=$$REP(DDWND,DDWFIND,.DDWCHG,DDWX,.DDWE),DDWF=1 . S:$G(DDWE) DDWE=DDWA+DDWMR+DDWSTB-DDWI+1_U_DDWE ; I $G(DDWF) D TOOLONG . D:$G(DDWE) MSG^DDW($C(7)_$$EZBLD^DIALOG(347)) H 2 ;** . F DDWI=1:1:$$MIN(DDWMR,DDWCNT-DDWA) D .. D CUP(DDWI,1) .. W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS) . D:$G(DDWE) LINE^DDWG(+DDWE,1),POS(DDWRW,$P(DDWE,U,2),"R") E D MSG^DDW("Text not found.") H 2 D FLUSH ; AEND D MSG^DDW(),CUP(DDWRW,DDWC) S DDWOPT=$S($G(DDWE):-1,1:"") Q ; REP(DDWND,DDWFIND,DDWCHG,DDWX,DDWE) ;String replacement of DDWND N DDWDIF,DDWFST,DDWSV S DDWDIF=$L(DDWCHG)-$L(DDWFIND) F D Q:'DDWX!$G(DDWE) . S DDWSV=DDWND,DDWFST=DDWX-$L(DDWFIND) . I $L(DDWND)+DDWDIF>245 S DDWE=DDWFST Q . S $E(DDWND,DDWFST,DDWX-1)=$S($E(DDWND,DDWFST)?1U:$G(DDWCHG(1),DDWCHG),1:DDWCHG) . S DDWX=DDWX+DDWDIF . S DDWX=$F($$UC(DDWND),DDWFIND,DDWX) Q $S($G(DDWE):DDWSV,1:DDWND) ; E ;Edit Find D FLUSH Q ; Q ;Quit option D FLUSH S DDWOPT=-1 Q ; H ;Help D MSG("Press the highlighted letter of one of the Options.") S DDWOPT="" Q ; CERR ;The Change options are disabled D MSG($C(7)_"You must Find the text before you can Change it.") S DDWOPT="" Q ; MSG(DDWX) ; D CUP(DDWMR+5,1) W $P(DDGLCLR,DDGLDEL)_$G(DDWX) H 2 D CUP(DDWMR+5,1) W $P(DDGLCLR,DDGLDEL) D FLUSH Q ; FLUSH ;Flush read buffer N DDWX F R *DDWX:0 E Q Q ; UC(X) ;Return uppercase of X Q $$UP^DILIBF(X) ;** ; MIN(X,Y) ; Q $S(XIOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q DDWC1^INT^1^60300,29510^0 DDWC1 ;SFISC/MKO-CHANGE ;04:37 PM 24 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 SETUP ;Setup new scrolling region N DDWI F DDWI=$$MIN(DDWMR,DDWCNT-DDWA):-1:DDWMR-4 D . S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWI) S IOBM=IOBM-5,DDWMR=DDWMR-5 W:$P(DDGLED,DDGLDEL,2)]"" @$P(DDGLED,DDGLDEL,2) ; ;Print dialog box N DDWR0,DDWR1 S DDWR1=$P(DDGLVID,DDGLDEL,6),DDWR0=$P(DDGLVID,DDGLDEL,10) ; D CUP(DDWMR+1,1) W $P(DDGLGRA,DDGLDEL)_$TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3))_$P(DDGLGRA,DDGLDEL,2),! FIND D CUP(DDWMR+2,1) W $P(DDGLCLR,DDGLDEL)_" "_$$EZBLD^DIALOG(8126) ;**'FIND WHAT:' D CUP(DDWMR+3,1) W $P(DDGLCLR,DDGLDEL)_$$EZBLD^DIALOG(8126.1)_$G(DDWCHG) ;**'REPLACE WITH:' D CUP(DDWMR+4,1) W $P(DDGLCLR,DDGLDEL)_" Option:"_$P(DDGLCLR,DDGLDEL)_$J("",20)_DDWR1_"F"_DDWR0_"ind Next "_DDWR1_"R"_DDWR0_"eplace Replace "_DDWR1_"A"_DDWR0_"ll "_DDWR1_"Q"_DDWR0_"uit" D CUP(DDWMR+5,1) W $P(DDGLCLR,DDGLDEL) Q ; RESTORE ;Restore original scrolling region N DDWI S IOBM=IOBM+5,DDWMR=DDWMR+5 W:$P(DDGLED,DDGLDEL,2)]"" @$P(DDGLED,DDGLDEL,2) F DDWI=DDWMR-4:1:DDWMR D . I DDWI+DDWA'>DDWCNT D .. S DDWL(DDWI)=^TMP("DDW1",$J,DDWSTB),DDWSTB=DDWSTB-1 . E S DDWL(DDWI)="" . D CUP(DDWI,1) . W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS) . D POS(DDWRW,DDWC,"RN") Q ; MIN(X,Y) ; Q $S(XIOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q DDWF^INT^1^60300,29510^0 DDWF ;SFISC/MKO-FIND, REPLACE ;02:43 PM 24 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 ; NEXT ;Find next occurrence of same text N DDWT G:$G(DDWFIND)="" FIND S DDWT=DDWFIND D FINDT(DDWT,$G(DDWFIND(1))) Q ; FIND ;Prompt and find text N DDWCOD,DDWF,DDWT D ASK^DDWG(3,$$EZBLD^DIALOG(8126),30,$G(DDWFIND),"","",.DDWT,.DDWCOD) ;**'FIND WHAT: ' Q:DDWT="" D FINDT(DDWT,$P($G(DDWCOD),U)="U") Q ; FINDT(DDWT,DDWBACK) ;Find DDWT D:$D(DDWMARK) UNMARK^DDW7 S DDWFIND=DDWT,DDWT=$$UC(DDWT) I $G(DDWBACK) D . S DDWFIND(1)=1 D LOOKB E K DDWFIND(1) D LOOK Q ; LOOK ;Look in arrays N DDWF,DDWI,DDWX S DDWF=$F($$UC(DDWL(DDWRW)),DDWT,DDWC) I DDWF D REPOS(DDWRW+DDWA,DDWF,DDWT) Q ; F DDWI=DDWRW+1:1:DDWMR D Q:DDWF . S DDWX=$F($$UC(DDWL(DDWI)),DDWT) . I DDWX D REPOS(DDWI+DDWA,DDWX,DDWT) S DDWF=1 Q:DDWF ; D MSG^DDW(" ...") ;** F DDWI=DDWSTB:-1:1 D Q:DDWF . S DDWX=$F($$UC(^TMP("DDW1",$J,DDWI)),DDWT) . I DDWX D .. D MSG^DDW() .. D REPOS(DDWA+DDWMR+DDWSTB-DDWI+1,DDWX,DDWT) .. S DDWF=1 Q:DDWF ; D MSG^DDW($$EZBLD^DIALOG(8127)) H 2 ;**'TEXT NOT FOUND' D MSG^DDW(),CUP(DDWRW,DDWC) F R *DDWX:0 E Q Q ; LOOKB ;Look backward in arrays N DDWF,DDWI,DDWX S DDWF=$$RF($E($$UC(DDWL(DDWRW)),1,DDWC-1),DDWT) I DDWF=DDWC S DDWF=$$RF($E($$UC(DDWL(DDWRW)),1,DDWC-$L(DDWT)-1),DDWT) I DDWF D REPOS(DDWRW+DDWA,DDWF,DDWT) Q ; F DDWI=DDWRW-1:-1:1 D Q:DDWF . S DDWX=$$RF($$UC(DDWL(DDWI)),DDWT) . I DDWX D REPOS(DDWI+DDWA,DDWX,DDWT) S DDWF=1 Q:DDWF ; D MSG^DDW(" ...") ;** F DDWI=DDWA:-1:1 D Q:DDWF . S DDWX=$$RF($$UC(^TMP("DDW",$J,DDWI)),DDWT) . I DDWX D .. D MSG^DDW() .. D REPOS(DDWI,DDWX,DDWT) .. S DDWF=1 Q:DDWF ; D MSG^DDW($$EZBLD^DIALOG(8127)) H 2 ;**'TEXT NOT FOUND' D MSG^DDW(),CUP(DDWRW,DDWC) F R *DDWX:0 E Q Q ; REPOS(DDWY,DDWX,DDWT) ;Define DDWMARK, paint if on screen S DDWMARK=DDWY_U_(DDWX-$L(DDWT))_U_DDWY_U_(DDWX-1) I DDWY-DDWA>0,DDWY-DDWA'>DDWMR,DDWX-DDWOFS>0,DDWX-DDWOFS'>IOM D . D PAINT^DDW7(DDWMARK,1) . D POS(DDWY-DDWA,DDWX,"RN") E D LINE^DDWG(DDWY,DDWX) D IND^DDW7(1) Q ; UC(X) ;Return uppercase of X Q $$UP^DILIBF(X) ;** ; RF(X,T) ;Find last occurrence of T in X N Y Q:X'[T 0 S Y=1 F S Y=$F(X,T,Y) Q:'$F(X,T,Y) Q Y ; CUP(Y,X) ;Cursor positioning S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q DDWG^INT^1^60300,29510^0 DDWG ;SFISC/MKO-GOTO ;05:49 PM 24 Aug 2002 ;;22.0;VA FileMan;**999**;Mar 30, 1999 GOTO ;Go to a specific location N DDWANS,DDWI,DDWHLP D BLD^DIALOG(8140,,,"DDWHLP") ;** D ASK(4,$$EZBLD^DIALOG(7069)_": ",17,"","D VALGTO",.DDWHLP,.DDWANS) ;** I U[DDWANS E I "Ss"[$E(DDWANS)!(DDWANS'?1A.E) D . D GOTOS E I "Ll"[$E(DDWANS) D . D GOTOL E I "Cc"[$E(DDWANS) D . D GOTOC Q ; GOTOS ;Go to a page N DDWS S DDWS=DDWANS S:DDWS?1A.E DDWS=$E(DDWS,2,999) S:DDWS?1P.E DDWS=$E(DDWS,2,999) I DDWANS["+" S DDWS=$$SCREEN+DDWS E I DDWANS["-" S DDWS=$$SCREEN-DDWS I DDWS<1 S DDWS=1 E I DDWS>$$LTOSC(DDWCNT) S DDWS=$$LTOSC(DDWCNT) D LINE(DDWS-1*DDWMR+1) Q ; GOTOL ;Go to a line N DDWLN S DDWLN=DDWANS S:DDWLN?1A.E DDWLN=$E(DDWLN,2,999) S:DDWLN?1P.E DDWLN=$E(DDWLN,2,999) I DDWANS["+" S DDWLN=DDWA+DDWRW+DDWLN E I DDWANS["-" S DDWLN=DDWA+DDWRW-DDWLN I DDWLN<1 S DDWLN=1 E I DDWLN>DDWCNT S DDWLN=DDWCNT D LINE(DDWLN) Q ; GOTOC ;Go to a column N DDWCOL S DDWCOL=DDWANS S:DDWCOL?1A.E DDWCOL=$E(DDWCOL,2,999) S:DDWCOL?1P.E DDWCOL=$E(DDWCOL,2,999) I DDWANS["+" S DDWCOL=DDWC+DDWCOL E I DDWANS["-" S DDWCOL=DDWC-DDWCOL I DDWCOL<1 S DDWCOL=1 E I DDWCOL>246 S DDWCOL=246 D POS(DDWRW,DDWCOL,"R") Q ; LINE(DDWLN,DDWCOL) ;Adjust arrays and position cursor on line DDWLN I $G(DDWCOL)'="E",'$G(DDWCOL) S DDWCOL=1 S:DDWLN>DDWCNT DDWLN=DDWCNT I DDWLN>DDWA,DDWLN'>(DDWA+DDWMR-1) D . D POS(DDWLN-DDWA,DDWCOL,"RN") E I DDWLN>DDWA D . D SHFTDN^DDW3(DDWLN,DDWCOL),POS(DDWLN-DDWA,DDWCOL,"RN") E D . D SHFTUP^DDW3(DDWLN),POS(1,DDWCOL,"RN") Q ; ASK(DDWLC,DDWS,DDWLEN,DDWDEF,DDWVAL,DDWHLP,DDWANS,DDWCOD) ;Prompt user N DDWI D CUP(DDWMR-DDWLC,1) W $P(DDGLGRA,DDGLDEL)_$TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3))_$P(DDGLGRA,DDGLDEL,2) F DDWI=DDWMR-DDWLC+1:1:DDWMR D CUP(DDWI,1) W $P(DDGLCLR,DDGLDEL) K DDWANS F D PROMPT Q:$D(DDWANS) ; F DDWI=DDWMR-DDWLC:1:DDWMR D . D CUP(DDWI,1) . W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS) D POS(DDWRW,DDWC,"RN") Q ; PROMPT ;Issue read N DDWERR,DDWX D CUP(DDWMR-DDWLC+1,1) W DDWS_$P(DDGLCLR,DDGLDEL) D EN^DIR0(IOTM+DDWMR-DDWLC-1,$L(DDWS),DDWLEN,1,$G(DDWDEF),245,"","","AKTW",.DDWX,.DDWCOD) ; I DDWX?1."?",$D(DDWHLP)>9!($G(DDWHLP)]"") D HELP(.DDWHLP) Q I $G(DDWVAL)]"" X DDWVAL I $D(DDWERR) W $C(7) D HELP(.DDWERR) Q S DDWANS=DDWX Q ; VALGTO ;Validate DDWX N DDWCH Q:U[DDWX S DDWERR=$$EZBLD^DIALOG(1401) ;** Q:DDWX'?.1A.1P1.15N I DDWX?1A.E S DDWCH=$E(DDWX) Q:"SsLlCc"'[DDWCH I DDWX?.E1P.E I DDWX'["+",DDWX'["-" Q K DDWERR Q ; HELP(DDWMSG) ;Print message N DDWI,DDWEC S:$D(DDWMSG)<9 DDWMSG(1)=DDWMSG S DDWEC=$O(DDWMSG(""),-1) F DDWI=2:1:DDWLC D . D CUP(DDWMR-DDWLC+DDWI,1) . W $P(DDGLCLR,DDGLDEL)_$G(DDWMSG(DDWI-DDWLC+DDWEC)) Q ; SCREEN() ;Return current screen Q DDWA+DDWRW-1\DDWMR+1 ; LTOSC(L) ;Convert line number to page number Q L-1\DDWMR+1 ; CUP(Y,X) ;Pos cursor S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q DDWH^INT^1^60300,29510^0 DDWH ;SFISC/MKO-SCREEN EDITOR HELP ;08:38 AM 23 Nov 1994 ;;22.0;VA FileMan;;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. HLP ; N DX,DY,DDWI ; D HLP^DDGLIBH(9211,9214,"DDWH",IOBM+2) D BOX^DDW1 ; S DY=IOTM-1,DX=0 X IOXY F DDWI=1:1:DDWMR W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK))_$S(DDWI(DDWR2-DDWA) D . N DDWX1,DDWX2 . S DDWX1=$S(DDWI=(DDWR1-DDWA):DDWC1,1:1) . S DDWX2=$S(DDWI=(DDWR2-DDWA):DDWC2,1:999) . S DDWX=$E(DDWL(DDWI),1+DDWOFS,DDWX1-1)_$P(DDGLVID,DDGLDEL,6)_$E(DDWL(DDWI),$$MAX(DDWX1,1+DDWOFS),$$MIN(DDWX2,IOM+DDWOFS))_$P(DDGLVID,DDGLDEL,10)_$E(DDWL(DDWI),$$MAX(DDWX2+1,1+DDWOFS),IOM+DDWOFS) Q DDWX ; MIN(X,Y) ; Q $S(XY:X,1:Y) DDWK^INT^1^60300,29510^0 DDWK ;SFISC/MKO-SCREEN EDITOR MAIN ROUTINE ;11:32 AM 25 Aug 2000 ;;22.0;VA FileMan;**18**;Mar 30, 1999 ;Per VHA Directive 10-93-142, this routine should not be modified. ; GETKEY ;Get key sequences and defaults N AU,AD,AR,AL,F1,F2,F3,F4 N FIND,SELECT,INSERT,REMOVE,PREVSC,NEXTSC N A1,A2,A3,I,K,N,T S AU=$P(DDGLKEY,U,2) S AD=$P(DDGLKEY,U,3) S AR=$P(DDGLKEY,U,4) S AL=$P(DDGLKEY,U,5) S F1=$P(DDGLKEY,U,6) S F2=$P(DDGLKEY,U,7) S F3=$P(DDGLKEY,U,8) S F4=$P(DDGLKEY,U,9) S FIND=$P(DDGLKEY,U,10) S SELECT=$P(DDGLKEY,U,11) S INSERT=$P(DDGLKEY,U,12) S REMOVE=$P(DDGLKEY,U,13) S PREVSC=$P(DDGLKEY,U,14) S NEXTSC=$P(DDGLKEY,U,15) ; S A1="DDW(""IN"")",A2="DDW(""OT"")",A3=0 S (DDW("IN"),DDW("OT"))="" F I=1:1 S T=$P($T(MAP+I),";;",2,999) Q:T="" D . S @("K="_$P(T,";",2)),T=$P(T,";") . I K]"",@A1'[(U_K) D .. I $L(@A1)+$L(K)+2>255!($L(@A2)+$L(T)+1>255) D ... S @A1=@A1_U,$E(@A2,$L(@A2))="" ... S A3=A3+1,A1=$NA(@A1@(A3)),A2=$NA(@A2@(A3)) ... S (@A1,@A2)="" .. S @A1=@A1_U_K .. S @A2=@A2_T_U S @A1=@A1_U,$E(@A2,$L(@A2))="" Q ; MAP ;Keys for main screen ;;UP;AU ;;DN;AD ;;RT;AR ;;LT;AL ;;TAB;$C(9) ;;PUP;F1_AU ;;PUP;PREVSC ;;PDN;F1_AD ;;PDN;NEXTSC ;;JLT;F1_AL ;;JRT;F1_AR ;;LB;