- DIP21 ;SFISC/XAK-PRINT TEMPLATE ;22JULY2014
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- 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
- EDITQ I L,Y'<1,(('$P(^DIPT(+Y,0),U,8))!($G(DDXP)=2&($P(^DIPT(+Y,0),U,8)=7))),'$G(^("CANONIC")) D W:DUZ(0)'="@" I S %=2 W !,$$EZBLD^DIALOG(8196,$P(Y,U,2)) D YN^DICN G ED^DIP23:%=1 ;'WANT TO EDIT'?
- K:'$D(^DIPT(+Y,"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)
- EGP 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:$D(DNP) ^("DNP")=1 ;*CCO/NI PLUS NEXT 3 LINES REMEMBER HEADING LANGUAGE
- I DHD]"" S ^("H")=DHD I $G(DUZ("LANG")) S ^("HLANG")=DUZ("LANG")
- 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 !,$$EZBLD^DIALOG(8195) S %=1 D YN^DICN G DIP21^DIQQQ:'%,Q^DIP:%<0 I %=1 S ^DIPT(+Y,"SUB")=1 S:'$G(DPP(0)) DISH=1 ;**CCO/NI SUBHEADERS QUESTION
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIP21 3722 printed Jan 18, 2025@03:53:41 Page 2
- DIP21 ;SFISC/XAK-PRINT TEMPLATE ;22JULY2014
- +1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- +7 DO D
- SET DIC(0)=$EXTRACT("E",'$DATA(FLDS)!''L)_"QZSI"
- +8 SET DIC("S")="I $D(^(""F""))"_$SELECT($GET(DIAR)=4:",$D(^(1))",$GET(DDXP)=2:",$P(^(0),U,8)=7",$GET(DDXP)=4:",$P(^(0),U,8)=3",1:"")_" "_DIC("S")
- if $GET(DDXP)=4
- SET DIC("W")=""
- +9 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
- +10 IF L
- IF +Y=.01
- KILL DPQ(DK)
- SET DIQ(0)=""
- DO C^DII
- if $DATA(DIRUT)
- GOTO Q^DIP
- EDITQ ;'WANT TO EDIT'?
- IF L
- IF Y'<1
- IF (('$PIECE(^DIPT(+Y,0),U,8))!($GET(DDXP)=2&($PIECE(^DIPT(+Y,0),U,8)=7)))
- IF '$GET(^("CANONIC"))
- if DUZ(0)'="@"
- DO W
- IF $TEST
- SET %=2
- WRITE !,$$EZBLD^DIALOG(8196,$PIECE(Y,U,2))
- DO YN^DICN
- if %=1
- GOTO ED^DIP23
- +1 if '$DATA(^DIPT(+Y,"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
- +2 DO F
- IF $GET(^DIPT(+Y,"ROU"))[U
- IF $$ROUEXIST^DILIBF($PIECE(^("ROU"),U,2))
- SET DIPZ=+Y
- if DHD="@"
- GOTO PAGE^DIP3
- +3 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)
- EGP ;*CCO/NI PLUS NEXT 3 LINES REMEMBER HEADING LANGUAGE
- 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 $DATA(DNP)
- SET ^("DNP")=1
- +1 IF DHD]""
- SET ^("H")=DHD
- IF $GET(DUZ("LANG"))
- SET ^("HLANG")=DUZ("LANG")
- +2 SET X=$DATA(^("DCL",0))
- +3 LOCK -^DIPT
- KILL DIPDT,%I
- +4 FOR S=0:0
- SET X=$ORDER(DCL(X))
- if X=""
- QUIT
- SET ^(X)=DCL(X)
- +5 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,%)
- +6 FOR S=1:1:DJ
- SET ^DIPT(+Y,"F",S)=^UTILITY("DIP2",$JOB,S)
- +7 IF DE]""
- SET ^DIPT(+Y,"F",S+1)=DE
- +8 IF $GET(DDXP)=2
- SET DDXPFDTM=+Y
- GOTO Q^DIP
- +9 IF $DATA(DIAR)
- SET DIARP=+Y
- SUB ;**CCO/NI SUBHEADERS QUESTION
- IF DHD="@"
- WRITE !,$$EZBLD^DIALOG(8195)
- 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