DIP2 ;SFISC/GFT-PRINT FLDS OR TEMPLATES ;2015-01-03 8:48 AM
;;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.
;
K ^UTILITY("DIP2",$J),DG,K,DISH,DIL,DXS,A,P,I,J S I(0)=DI,(DE,DINS,DV,DNP)="",(DXS,DL,R)=1,(DIPT,DJ,DCL,DIL)=0,DK=+$P(@(DI_"0)"),U,2),J(0)=DK
EN ;
F S (P,S)=""
1 ;
B S DU=$P(^DD(DK,0),U) I DL>1 S:DU="FIELD" DU=$O(^(0,"NM",0))_" "_DU I $O(^($O(^DD(DK,0))))'>0,$P(^(.01,0),U,2)["W" S:'DINS&DC DC=DC-2 S Y=.01 D P G N
K DIC,Y K:$D(DALL)<9 DALL I ('L!($G(DDXP)=4)),$D(FLDS) S X=$P(FLDS,",",R),R=R+1 G LIT ;**CCO/NI
I DC D ^DIP22:'$D(DC(DC)) ;DC is non-null if we are editing a Print Template.
2 W !?DL+DL-2 K X S X(1)=$$EZBLD^DIALOG($S(DE]""!($D(DJ)>9):7066,1:7065)),X(2)=DU W $$EZBLD^DIALOG($S($G(DDXP)=2:7064,1:7063),.X) K X ;'FIRST/THEN PRINT/EXPORT'
I DC D RW(DC(DC)) G Q^DIP:X=U!($D(DTOUT)) S DINS=X?1"^"1E.E,X=$S(DINS:$E(X,2,999),X="":DC(DC),1:X) S:DC(DC)=""&$L(X) DINS=1 G XPCK
I $D(DIRPIPE) X DIRPIPE G LIT ;XECUTABLE CODE FOR IHS
I DL=1,DE="",$D(DJ)<9,'$D(DDXP) S Y=$$FIND^DIUCANON(.4,DK) I Y D G LIT
. N DIUCANON S DIUCANON=1
. D RW("["_$P(Y,U,2)_"]")
R X:DTIME S:'$T X=U G Q^DIP:X=U
I X="ALL",DE="",$D(DJ)<2 D G:$D(DIRUT) Q^DIP D:Y&($G(DDXP)=2) VALALL^DDXP2 G N:Y,F:'$D(X) W !?10,X
. S DIR(0)="YA",DIR("A")=$$EZBLD^DIALOG(7067),DIR("B")="NO",DIR("?")=$$EZBLD^DIALOG(7067.1),%XX=X
. D ^DIR S X=%XX K DIR,%XX S:$D(DIRUT) X=U Q
XPCK I $G(DDXP)=2 D VAL1^DDXP2 G:'$D(X) F
LIT I $E(X)="""",$L(X,"""")#2 F A9=3:2:$L(X,Q) Q:$P(X,Q,A9)]""&($E($P(X,Q,A9)'=$C(95)))
I I $P($P(X,Q,A9),";")="" K A9 S S=X G S:DINS,S:'$D(DIAR),S:DIAR'=4,S:'$D(DC(DC)),S:DC=0,Z^DIP22
S DIC="^DD(DK,",DIC(0)=$E("ZE",1,'$D(FLDS)!''L+1)_$E("O",1,DC>0),DIC("W")="S %=$P(^(0),U,2) I % W $S($P(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")" S:$D(DICS) DIC("S")=DICS
DIC G DIC^DIP22
RTN I DC,X="@" D DC G F
NUMBER G DIP2^DIQQ:X?."?",Q^DIP:X=U I $P($$EZBLD^DIALOG(7099),X)="" W $P($$EZBLD^DIALOG(7099),X,2) S S=0_S G S ;**CCO/NI THE WORD 'NUMBER'
S DIC(0)="EYZ",D="GR" I $D(^DD(DK,D)) D IX^DIC G GF:Y>0 I 'Y F Y=0:0 S Y=$O(Y(Y)) G F:Y="" S X=^DD(DK,Y,0) D Y
G HARD^DIP22
;
GF I $G(DDXP)=2 D VAL2^DDXP2 G:'$D(Y(0)) F
I $P(Y(0),U,2) D D,DC:DC S X=$P($P(Y(0),U,4),";",1),I(DIL)=$S(+X=X:X,1:Q_X_Q),J(DIL)=DK G 1
I +Y=.001 S Y=0
S S=+Y_S I P]"",$D(DCL(DK_U_+Y)) G QQ^DIP22
S I $G(DDXP)=2 D VAL3^DDXP2 G:'$D(S) F
D DJ G F
;
D S DIL(DL)=DIL,DV(DL)=DV,DL(DL)=DK,DK=+$P(^DD(DK,+Y,0),U,2),DL=DL+1,DIL=DIL+1,DV=DV_+Y_C,Y=0 Q
;
U S DL=DL-1,DV=DV(DL),DK=DL(DL),DIL=DIL(DL) F %=DIL:0 S %=$O(I(%)) Q:%="" K I(%),J(%)
Q
;
DC I 'DINS K:DC>1 DC(DC) S DC=DC+1
Q
;
Y S S=Y_S
DJ I $L(DE)+$L(S)>150 S DJ=DJ+1,^UTILITY("DIP2",$J,DJ)=DE,DE=""
S DE=DE_DV_S_$C(126),S="" D DC:DC
P Q:'$D(P) I P="" K DNP Q
I P="*" S DCL=DCL+1
S DCL(DK_U_+Y)=$S($T:DCL_P,1:P) Q
;
N S I=DL S:I=1 DALL=1
NN S Y=.001 I $D(^DD(DK,Y)) S Y=0 D Y S Y=.001
A S Y=$O(^DD(DK,Y)) I Y,$D(^(Y,8)),$D(DICS) X DICS E G A
I Y'>0 G UP:I'<DL S Y=$P(DV,C,DL-1) D U G A
I $P(^(0),U,2) D D G NN
D Y G A
;
UP K DIC I DL>1 D U,DC:DC G F
I DE="",'DJ,'$D(DHIT),'$D(DIS) G F
I $D(FLDS)>9 S X=$O(FLDS("")) I X]"" S FLDS=FLDS(X),R=1 K FLDS(X) G F
G ^DIP3
;
RW(Y) ;sets X, and maybe DTOUT
W Y I $L(Y)>19,'$G(DIUCANON) D RW^DIR2 Q
W "// " R X:DTIME E S X=U,DTOUT=1 W $C(7) Q
S:X="" X=Y Q
;
;
;
ER S (X,DU)="[CAPTIONED]" G ^DIP21 ;WHAT CALLS THIS??
;7063= PRINT:
;7064= EXPORT:
;7065= FIRST
;7066= THEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIP2 3718 printed Apr 09, 2024@21:48:50 Page 2
DIP2 ;SFISC/GFT-PRINT FLDS OR TEMPLATES ;2015-01-03 8:48 AM
+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 KILL ^UTILITY("DIP2",$JOB),DG,K,DISH,DIL,DXS,A,P,I,J
SET I(0)=DI
SET (DE,DINS,DV,DNP)=""
SET (DXS,DL,R)=1
SET (DIPT,DJ,DCL,DIL)=0
SET DK=+$PIECE(@(DI_"0)"),U,2)
SET J(0)=DK
EN ;
F SET (P,S)=""
1 ;
B SET DU=$PIECE(^DD(DK,0),U)
IF DL>1
if DU="FIELD"
SET DU=$ORDER(^(0,"NM",0))_" "_DU
IF $ORDER(^($ORDER(^DD(DK,0))))'>0
IF $PIECE(^(.01,0),U,2)["W"
if 'DINS&DC
SET DC=DC-2
SET Y=.01
DO P
GOTO N
+1 ;**CCO/NI
KILL DIC,Y
if $DATA(DALL)<9
KILL DALL
IF ('L!($GET(DDXP)=4))
IF $DATA(FLDS)
SET X=$PIECE(FLDS,",",R)
SET R=R+1
GOTO LIT
+2 ;DC is non-null if we are editing a Print Template.
IF DC
if '$DATA(DC(DC))
DO ^DIP22
2 ;'FIRST/THEN PRINT/EXPORT'
WRITE !?DL+DL-2
KILL X
SET X(1)=$$EZBLD^DIALOG($SELECT(DE]""!($DATA(DJ)>9):7066,1:7065))
SET X(2)=DU
WRITE $$EZBLD^DIALOG($SELECT($GET(DDXP)=2:7064,1:7063),.X)
KILL X
+1 IF DC
DO RW(DC(DC))
if X=U!($DATA(DTOUT))
GOTO Q^DIP
SET DINS=X?1"^"1E.E
SET X=$SELECT(DINS:$EXTRACT(X,2,999),X="":DC(DC),1:X)
if DC(DC)=""&$LENGTH(X)
SET DINS=1
GOTO XPCK
+2 ;XECUTABLE CODE FOR IHS
IF $DATA(DIRPIPE)
XECUTE DIRPIPE
GOTO LIT
+3 IF DL=1
IF DE=""
IF $DATA(DJ)<9
IF '$DATA(DDXP)
SET Y=$$FIND^DIUCANON(.4,DK)
IF Y
Begin DoDot:1
+4 NEW DIUCANON
SET DIUCANON=1
+5 DO RW("["_$PIECE(Y,U,2)_"]")
End DoDot:1
GOTO LIT
+6 READ X:DTIME
if '$TEST
SET X=U
if X=U
GOTO Q^DIP
+7 IF X="ALL"
IF DE=""
IF $DATA(DJ)<2
Begin DoDot:1
+8 SET DIR(0)="YA"
SET DIR("A")=$$EZBLD^DIALOG(7067)
SET DIR("B")="NO"
SET DIR("?")=$$EZBLD^DIALOG(7067.1)
SET %XX=X
+9 DO ^DIR
SET X=%XX
KILL DIR,%XX
if $DATA(DIRUT)
SET X=U
QUIT
End DoDot:1
if $DATA(DIRUT)
GOTO Q^DIP
if Y&($GET(DDXP)=2)
DO VALALL^DDXP2
if Y
GOTO N
if '$DATA(X)
GOTO F
WRITE !?10,X
XPCK IF $GET(DDXP)=2
DO VAL1^DDXP2
if '$DATA(X)
GOTO F
LIT IF $EXTRACT(X)=""""
IF $LENGTH(X,"""")#2
FOR A9=3:2:$LENGTH(X,Q)
if $PIECE(X,Q,A9)]""&($EXTRACT($PIECE(X,Q,A9)'=$CHAR(95)))
QUIT
+1 IF $TEST
IF $PIECE($PIECE(X,Q,A9),";")=""
KILL A9
SET S=X
if DINS
GOTO S
if '$DATA(DIAR)
GOTO S
if DIAR'=4
GOTO S
if '$DATA(DC(DC))
GOTO S
if DC=0
GOTO S
GOTO Z^DIP22
+2 SET DIC="^DD(DK,"
SET DIC(0)=$EXTRACT("ZE",1,'$DATA(FLDS)!''L+1)_$EXTRACT("O",1,DC>0)
SET DIC("W")="S %=$P(^(0),U,2) I % W $S($P(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")"
if $DATA(DICS)
SET DIC("S")=DICS
DIC GOTO DIC^DIP22
RTN IF DC
IF X="@"
DO DC
GOTO F
NUMBER ;**CCO/NI THE WORD 'NUMBER'
if X?."?"
GOTO DIP2^DIQQ
if X=U
GOTO Q^DIP
IF $PIECE($$EZBLD^DIALOG(7099),X)=""
WRITE $PIECE($$EZBLD^DIALOG(7099),X,2)
SET S=0_S
GOTO S
+1 SET DIC(0)="EYZ"
SET D="GR"
IF $DATA(^DD(DK,D))
DO IX^DIC
if Y>0
GOTO GF
IF 'Y
FOR Y=0:0
SET Y=$ORDER(Y(Y))
if Y=""
GOTO F
SET X=^DD(DK,Y,0)
DO Y
+2 GOTO HARD^DIP22
+3 ;
GF IF $GET(DDXP)=2
DO VAL2^DDXP2
if '$DATA(Y(0))
GOTO F
+1 IF $PIECE(Y(0),U,2)
DO D
if DC
DO DC
SET X=$PIECE($PIECE(Y(0),U,4),";",1)
SET I(DIL)=$SELECT(+X=X:X,1:Q_X_Q)
SET J(DIL)=DK
GOTO 1
+2 IF +Y=.001
SET Y=0
+3 SET S=+Y_S
IF P]""
IF $DATA(DCL(DK_U_+Y))
GOTO QQ^DIP22
S IF $GET(DDXP)=2
DO VAL3^DDXP2
if '$DATA(S)
GOTO F
+1 DO DJ
GOTO F
+2 ;
D SET DIL(DL)=DIL
SET DV(DL)=DV
SET DL(DL)=DK
SET DK=+$PIECE(^DD(DK,+Y,0),U,2)
SET DL=DL+1
SET DIL=DIL+1
SET DV=DV_+Y_C
SET Y=0
QUIT
+1 ;
U SET DL=DL-1
SET DV=DV(DL)
SET DK=DL(DL)
SET DIL=DIL(DL)
FOR %=DIL:0
SET %=$ORDER(I(%))
if %=""
QUIT
KILL I(%),J(%)
+1 QUIT
+2 ;
DC IF 'DINS
if DC>1
KILL DC(DC)
SET DC=DC+1
+1 QUIT
+2 ;
Y SET S=Y_S
DJ IF $LENGTH(DE)+$LENGTH(S)>150
SET DJ=DJ+1
SET ^UTILITY("DIP2",$JOB,DJ)=DE
SET DE=""
+1 SET DE=DE_DV_S_$CHAR(126)
SET S=""
if DC
DO DC
P if '$DATA(P)
QUIT
IF P=""
KILL DNP
QUIT
+1 IF P="*"
SET DCL=DCL+1
+2 SET DCL(DK_U_+Y)=$SELECT($TEST:DCL_P,1:P)
QUIT
+3 ;
N SET I=DL
if I=1
SET DALL=1
NN SET Y=.001
IF $DATA(^DD(DK,Y))
SET Y=0
DO Y
SET Y=.001
A SET Y=$ORDER(^DD(DK,Y))
IF Y
IF $DATA(^(Y,8))
IF $DATA(DICS)
XECUTE DICS
IF '$TEST
GOTO A
+1 IF Y'>0
if I'<DL
GOTO UP
SET Y=$PIECE(DV,C,DL-1)
DO U
GOTO A
+2 IF $PIECE(^(0),U,2)
DO D
GOTO NN
+3 DO Y
GOTO A
+4 ;
UP KILL DIC
IF DL>1
DO U
if DC
DO DC
GOTO F
+1 IF DE=""
IF 'DJ
IF '$DATA(DHIT)
IF '$DATA(DIS)
GOTO F
+2 IF $DATA(FLDS)>9
SET X=$ORDER(FLDS(""))
IF X]""
SET FLDS=FLDS(X)
SET R=1
KILL FLDS(X)
GOTO F
+3 GOTO ^DIP3
+4 ;
RW(Y) ;sets X, and maybe DTOUT
+1 WRITE Y
IF $LENGTH(Y)>19
IF '$GET(DIUCANON)
DO RW^DIR2
QUIT
+2 WRITE "// "
READ X:DTIME
IF '$TEST
SET X=U
SET DTOUT=1
WRITE $CHAR(7)
QUIT
+3 if X=""
SET X=Y
QUIT
+4 ;
+5 ;
+6 ;
ER ;WHAT CALLS THIS??
SET (X,DU)="[CAPTIONED]"
GOTO ^DIP21
+1 ;7063= PRINT:
+2 ;7064= EXPORT:
+3 ;7065= FIRST
+4 ;7066= THEN
