DIP21 ;SFISC/XAK-PRINT TEMPLATE ;8/6/96 17:23
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
D D S DIC(0)=$E("E",'$D(FLDS)!''L)_"QZSI"
S DIC("S")="I $D(^(""F""))"_$S($G(DIAR)=4:",$D(^(1))",$G(DDXP)=2:",$P(^(0),U,8)=7",$G(DDXP)=4:",$P(^(0),U,8)=3",1:"")_" "_DIC("S") S:$G(DDXP)=4 DIC("W")=""
D IX^DIC K DIC S:(+Y=.01&(DUZ(0)'="@")) DICSS=$$ACC(8) I Y<0 G Q^DIP:$D(DTOUT),^DIP2:L,^DIP2:'$D(FLDS),Q^DIP
I L,+Y=.01 K DPQ(DK) S DIQ(0)="" D C^DII G:$D(DIRUT) Q^DIP
I L,Y'<1,(('$P(^DIPT(+Y,0),U,8))!($G(DDXP)=2&($P(^DIPT(+Y,0),U,8)=7))) D W:DUZ(0)'="@" I S %=2 W !,"WANT TO EDIT '",$P(Y,U,2),"' TEMPLATE" D YN^DICN G ED^DIP23:%=1
K:'$D(^("DNP")) DNP S DIPT=+Y,DALL=1,DHD=$S($D(DHD)#2:DHD,$D(^("H")):^("H"),1:""),DC(0)=+Y I $D(^("SUB")),^("SUB") S:'$G(DPP(0)) DISH=1
D F I $G(^DIPT(+Y,"ROU"))[U,$$ROUEXIST^DILIBF($P(^("ROU"),U,2)) S DIPZ=+Y G PAGE^DIP3:DHD="@"
Q:$D(DTOUT) G H^DIP3
F ;
S DE="",R=0
F X=0:0 S R=$O(^DIPT(+Y,"DCL",R)) Q:R="" F D=1:1 Q:D>$L(^(R)) S Z=$E(^(R),D) I Z?1P S DCL(R)=$G(DCL(R))_Z
F X=0:0 S X=$O(^DIPT(+Y,"DXS",X)),%=-1 Q:X="" Q:$O(^(X,%))="" I '$D(DIPZ)!$D(^(9.2))!$D(^(9)) F X=X:0 S %=$O(^(%)) Q:%="" S DXS(X,%)=^(%)
Q
XPUT ;
D XPDIP21^DIQQQ
PUT ;
D NOW^%DTC S DIPDT=+$J(%,0,4) W !,"STORE "_$S($G(DDXP)=2:"EXPORT",1:"PRINT")_" LOGIC IN TEMPLATE: " R X:DTIME G Q^DIP:X=U!'$T,XPUT:($D(DDXP)&(X="")),OUT:X=""
D D S DIC(0)="ELZSQ",DIC("S")="I Y'<1,$P(^(0),U,8)'=1,$P(^(0),U,8)'=3 "_DIC("S"),Y=-1,DLAYGO=0 D IX^DIC:X]"" K DIC,DLAYGO G:Y<0 PUT:X'[U,Q^DIP
S S=$O(^DIPT(+Y,0)),DA=$S('$D(^("ROU")):1,^("ROU")'[U:1,'$D(^("IOM")):1,'$D(^("ROUOLD")):1,1:^("ROUOLD")) S:'DA IOM=^("IOM")
I S]"" W $C(7),!,"TEMPLATE ALREADY STORED THERE...." D W:DUZ(0)'="@" G PUT:'$T W " OK TO REPLACE" S %=0 D YN^DICN W ! G PUT:%-1 L +^DIPT S %Y="" F %X=0:0 S %Y=$O(^DIPT(+Y,%Y)) Q:%Y="" K:",%D,ROUOLD,W,"'[(","_%Y_",") ^DIPT(+Y,%Y)
S ^DIPT("F"_J(0),$P(Y,U,2),+Y)=1,^DIPT(+Y,0)=$P(Y,U,2)_U_DIPDT_U_$S(S!(S=""):DUZ(0),1:$P(Y(0),U,3))_U_J(0)_U_DUZ_U_$S(S!(S=""):DUZ(0),1:$P(Y(0),U,6))_U_DT S:DHD]"" ^("H")=DHD S:$D(DNP) ^("DNP")=1 S X=$D(^("DCL",0)) L -^DIPT K DIPDT,%I
F S=0:0 S X=$O(DCL(X)) Q:X="" S ^(X)=DCL(X)
F S=0:0 S S=$O(DXS(S)) Q:S="" F %=0:0 S %=$O(DXS(S,%)) Q:%="" S ^DIPT(+Y,"DXS",S,%)=DXS(S,%)
F S=1:1:DJ S ^DIPT(+Y,"F",S)=^UTILITY("DIP2",$J,S)
I DE]"" S ^DIPT(+Y,"F",S+1)=DE
I $G(DDXP)=2 S DDXPFDTM=+Y G Q^DIP
I $D(DIAR) S DIARP=+Y
SUB I DHD="@" W !,"DO YOU ALWAYS WANT TO SUPPRESS SUBHEADERS WHEN PRINTING TEMPLATE" S %=1 D YN^DICN G DIP21^DIQQQ:'%,Q^DIP:%<0 I %=1 S ^DIPT(+Y,"SUB")=1 S:'$G(DPP(0)) DISH=1
I 'DA,$D(^DD("OS",DISYS,"ZS")) S X=DA,DMAX=^DD("ROU") D ENDIP^DIPZ I $D(^DIPT(DIPZ,"H")) S DHD=^("H")
OUT G PAGE^DIP3
;
W S %=$P(^(0),U,6) F X=1:1:$L(%) I DUZ(0)[$E(%,X) Q
Q
D ;
S X=$P(X,"]"),X=$P(X,"[")_$P(X,"[",2),D="F"_DK S:'$D(^DIPT(D,"CAPTIONED",.01)) ^(.01)=1 I $D(^DIPT("B","WPDI",.001)),'$D(^DIPT(D,"WPDI",.001)) S ^(.001)=1
K DIC S DIC="^DIPT("
S DIC("S")="S %=^(0) I $P(%,U,8)'=2!($G(DIAR)=6),$P(%,U,8)'=3!($G(DDXP)=4),$P(%,U,8)'=7!($G(DDXP)=2),$P(%,U,4)=DK!'$L($P(%,U,4))"_$P(" F DW=1:1:$L($P(%,U,3)) I DUZ(0)[$E($P(%,U,3),DW) Q",U,DUZ(0)'="@"&(L!($D(DIASKHD))))
Q
ACC(ND) ;set xcutable code to check FIELD access (in ND) against DUZ(0)
N A
S A="N % I 1 Q:'$D(^("_ND_")) F %=1:1:$L(^("_ND_")) I DUZ(0)[$E(^("_ND_"),%) Q"
Q A
DIP21 ;SFISC/XAK-PRINT TEMPLATE ;8/6/96 17:23
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO D
SET DIC(0)=$EXTRACT("E",'$DATA(FLDS)!''L)_"QZSI"
+4 SET DIP21_source.html#xD">DIC("S")="I $DIP21_source.html#xD">D(^(""F""))"_$SELECT($GET(DIP21_source.html#xD">DIAR)=4:",$DIP21_source.html#xD">D(^(1))",$GET(DIP21_source.html#xD">DDIP21_source.html#xD">DXP)=2:",$P(^(0),U,8)=7",$GET(DIP21_source.html#xD">DDIP21_source.html#xD">DXP)=4:",$P(^(0),U,8)=3",1:"")_" "_DIP21_source.html#xD">DIC("S")
IF $GET(DDXP)=4
SET DIC("W")=""
+5 DO IX^DIC
KILL DIC
IF (+Y=.01&(DUZ(0)'="@"))
SET DICSS=$$ACC(8)
IF Y<0
IF $DATA(DTOUT)
GOTO Q^DIP
IF L
GOTO ^DIP2
IF '$DATA(FLDS)
GOTO ^DIP2
GOTO Q^DIP
+6 IF L
IF +Y=.01
KILL DPQ(DK)
SET DIQ(0)=""
DO C^DII
IF $DATA(DIRUT)
GOTO Q^DIP
+7 IF L
IF Y'<1
IF (('$PIECE(^DIPT(+Y,0),U,8))!($GET(DDXP)=2&($PIECE(^DIPT(+Y,0),U,8)=7)))
IF DUZ(0)'="@"
DO W
IF $TEST
SET %=2
WRITE !,"WANT TO EDIT '",$PIECE(Y,U,2),"' TEMPLATE"
DO YN^DICN
IF %=1
GOTO ED^DIP23
+8 IF '$DATA(^("DNP"))
KILL DNP
SET DIPT=+Y
SET DALL=1
SET DHD=$SELECT($DATA(DHD)#2:DHD,$DATA(^("H")):^("H"),1:"")
SET DC(0)=+Y
IF $DATA(^("SUB"))
IF ^("SUB")
IF '$GET(DPP(0))
SET DISH=1
+9 DO F
IF $GET(^DIPT(+Y,"ROU"))[U
IF $$ROUEXIST^DILIBF($PIECE(^("ROU"),U,2))
SET DIPZ=+Y
IF DHD="@"
GOTO PAGE^DIP3
+10 IF $DATA(DTOUT)
QUIT
GOTO H^DIP3
F ;
+1 SET DE=""
SET R=0
+2 FOR X=0:0
SET R=$ORDER(^DIPT(+Y,"DCL",R))
IF R=""
QUIT
FOR D=1:1
IF D>$LENGTH(^(R))
QUIT
SET Z=$EXTRACT(^(R),D)
IF Z?1P
SET DCL(R)=$GET(DCL(R))_Z
+3 FOR X=0:0
SET X=$ORDER(^DIPT(+Y,"DXS",X))
SET %=-1
IF X=""
QUIT
IF $ORDER(^(X,%))=""
QUIT
IF '$DATA(DIPZ)!$DATA(^(9.2))!$DATA(^(9))
FOR X=X:0
SET %=$ORDER(^(%))
IF %=""
QUIT
SET DXS(X,%)=^(%)
+4 QUIT
XPUT ;
+1 DO XPDIP21^DIQQQ
PUT ;
+1 DO NOW^%DTC
SET DIPDT=+$JUSTIFY(%,0,4)
WRITE !,"STORE "_$SELECT($GET(DDXP)=2:"EXPORT",1:"PRINT")_" LOGIC IN TEMPLATE: "
READ X:DTIME
IF X=U!'$TEST
GOTO Q^DIP
IF ($DATA(DDXP)&(X=""))
GOTO XPUT
IF X=""
GOTO OUT
+2 DO D
SET DIC(0)="ELZSQ"
SET DIC("S")="I Y'<1,$P(^(0),U,8)'=1,$P(^(0),U,8)'=3 "_DIC("S")
SET Y=-1
SET DLAYGO=0
IF X]""
DO IX^DIC
KILL DIC,DLAYGO
IF Y<0
IF X'[U
GOTO PUT
GOTO Q^DIP
+3 SET S=$ORDER(^DIPT(+Y,0))
SET DA=$SELECT('$DATA(^("ROU")):1,^("ROU")'[U:1,'$DATA(^("IOM")):1,'$DATA(^("ROUOLD")):1,1:^("ROUOLD"))
IF 'DA
SET IOM=^("IOM")
+4 IF S]""
WRITE $CHAR(7),!,"TEMPLATE ALREADY STORED THERE...."
IF DUZ(0)'="@"
DO W
IF '$TEST
GOTO PUT
WRITE " OK TO REPLACE"
SET %=0
DO YN^DICN
WRITE !
IF %-1
GOTO PUT
LOCK +^DIPT
SET %Y=""
FOR %X=0:0
SET %Y=$ORDER(^DIPT(+Y,%Y))
IF %Y=""
QUIT
IF ",%D,ROUOLD,W,"'[(","_%Y_",")
KILL ^DIPT(+Y,%Y)
+5 SET ^DIPT("F"_J(0),$PIECE(Y,U,2),+Y)=1
SET ^DIPT(+Y,0)=$PIECE(Y,U,2)_U_DIPDT_U_$SELECT(S!(S=""):DUZ(0),1:$PIECE(Y(0),U,3))_U_J(0)_U_DUZ_U_$SELECT(S!(S=""):DUZ(0),1:$PIECE(Y(0),U,6))_U_DT
IF DHD]""
SET ^("H")=DHD
IF $DATA(DNP)
SET ^("DNP")=1
SET X=$DATA(^("DCL",0))
LOCK -^DIPT
KILL DIPDT,%I
+6 FOR S=0:0
SET X=$ORDER(DCL(X))
IF X=""
QUIT
SET ^(X)=DCL(X)
+7 FOR S=0:0
SET S=$ORDER(DXS(S))
IF S=""
QUIT
FOR %=0:0
SET %=$ORDER(DXS(S,%))
IF %=""
QUIT
SET ^DIPT(+Y,"DXS",S,%)=DXS(S,%)
+8 FOR S=1:1:DJ
SET ^DIPT(+Y,"F",S)=^UTILITY("DIP2",$JOB,S)
+9 IF DE]""
SET ^DIPT(+Y,"F",S+1)=DE
+10 IF $GET(DDXP)=2
SET DDXPFDTM=+Y
GOTO Q^DIP
+11 IF $DATA(DIAR)
SET DIARP=+Y
SUB IF DHD="@"
WRITE !,"DO YOU ALWAYS WANT TO SUPPRESS SUBHEADERS WHEN PRINTING TEMPLATE"
SET %=1
DO YN^DICN
IF '%
GOTO DIP21^DIQQQ
IF %<0
GOTO Q^DIP
IF %=1
SET ^DIPT(+Y,"SUB")=1
IF '$GET(DPP(0))
SET DISH=1
+1 IF 'DA
IF $DATA(^DD("OS",DISYS,"ZS"))
SET X=DA
SET DMAX=^DD("ROU")
DO ENDIP^DIPZ
IF $DATA(^DIPT(DIPZ,"H"))
SET DHD=^("H")
OUT GOTO PAGE^DIP3
+1 ;
W SET %=$PIECE(^(0),U,6)
FOR X=1:1:$LENGTH(%)
IF DUZ(0)[$EXTRACT(%,X)
QUIT
+1 QUIT
D ;
+1 SET X=$PIECE(X,"]")
SET X=$PIECE(X,"[")_$PIECE(X,"[",2)
SET D="F"_DK
IF '$DATA(^DIPT(D,"CAPTIONED",.01))
SET ^(.01)=1
IF $DATA(^DIPT("B","WPDI",.001))
IF '$DATA(^DIPT(D,"WPDI",.001))
SET ^(.001)=1
+2 KILL DIC
SET DIC="^DIPT("
+3 SET DIC("S")="S %=^(0) I $P(%,U,8)'=2!($G(DIAR)=6),$P(%,U,8)'=3!($G(DDXP)=4),$P(%,U,8)'=7!($G(DDXP)=2),$P(%,U,4)=DK!'$L($P(%,U,4))"_$PIECE(" F DW=1:1:$L($P(%,U,3)) I DUZ(0)[$E($P(%,U,3),DW) Q",U,DUZ(0)'="@"&(L!($DATA(DIASKHD))))
+4 QUIT
ACC(ND) ;set xcutable code to check FIELD access (in ND) against DUZ(0)
+1 NEW A
+2 SET A="N % I 1 Q:'$D(^("_ND_")) F %=1:1:$L(^("_ND_")) I DUZ(0)[$E(^("_ND_"),%) Q"
+3 QUIT A
