DIL ;SFISC/GFT/XAK-TURN PRINT FLDS INTO CODE ;2DEC2002 [ 12/09/2003 4:09 PM ]
;;22.0;VA FileMan;**25,102,119,1002**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
LOOP F DD=1:1 S W=$P(R,$C(126),DD) G Q:W="" S:DIWL DIWL=9 D DM I DIO D S DIO=0
.S DN=-8 Q:DIO=1
.I DIO=3 D UN
.S DIWR(DM)=DX,Y=" D 0^DIWW" D PX
;
DM I DM G UP:$P(W,F)]"" S W=$P(W,F,2,999)
I W[";Y" S DE="" D W:DG S I=+$P(W,";Y",2),DG=0,Y=DE_" F Y=0:0 Q:$Y>"_$S(I>0:I-2,1:"(IOSL"_(I-2)_")")_" W !" S:I>0 M(DP)=I D PX S O=999
G ^DIL1:'W,^DIL11:W?.NP1",".E,^DIL1:$P(W,";",1)'=+W K DPQ(DP,+W)
D DE,^DIL0 G T:DU=DN I $P(X,U,2)["C" S DN=-2 G PX
S DN=DU,Y=" S X=$G("_DI_C_DN_"))"_Y
PX ;
I DHT G PX^DIPZ1:DHT<0 S ^UTILITY($J,DV)=$E(Y,2,999),Y="",DV=DV+1 Q
S DX=DX+1 G PX:$D(^UTILITY($J,99,DX)) S ^(DX)=$E(Y,2,999)
D DX(DX)
S O=0
Q Q
;
DE S DE="" I W[";S" D W:DG S I=+$P(W,";S",2),DG=0 S:'I I=1 S M(DP)=M(DP)+I,DE=DE_" D T Q:'DN " F I=I:-1:1 S DE=DE_" D N"
I $P(W,";C",2) S DIC=$P(W,";C",2) S:DIC<0 DIC=IOM+DIC+1 D W:DIC<DG S DG=DIC-1 I 1
I DN=-4!$T S DE=DE_" D N:$X>"_DG_" Q:'DN "
S DE=DE_" W ?"_DG Q
W ;
D DIWR^DIL0:$D(DIWR)
A ;
K V S M(DP)=M(DP)+1 I DHD D
.S I=99,V="" F S V=$O(^UTILITY("DIL",$J,V)) Q:V="" S Z=$O(^(V,0)) I I>Z S I=Z
.F I=I:1:99 S Z="W !" D I Z'="W !" D U
..S V="" F S V=$O(^UTILITY("DIL",$J,V)) Q:V="" I $D(^(V,I)) S %=$G(^($O(^(0))-I+99)) D
...F Q:%'?1" ".E S V=V+1,%=$E(%,2,999)
...I $L(Z)+$L(%)>245 D U
...S Z=Z_",?"_V_","""_%_""""
K ^UTILITY("DIL",$J) Q
;
U S ^UTILITY($J,DHD)=Z,DHD=DHD+1,Z="W """"" Q
;
D ;
D PX:DHT<1 S F(DM)=DX,R(DX)=DP(DM),R(DX,1)=M(DP(DM)),F=F_W_",",DM=DM+1,DIL=DIL+1,DD=DD-1 I DHT+1 S DX=$S('DHT:900,1:DX) D:DHT PX Q
G DE^DIPZ1
;
UP D UN G DM
;
UNSTACK ;
D UN Q:'DM G UNSTACK
;
UN ;
D DIWR^DIL0:$D(DIWR(DM))
D:DHT<0 UP^DIPZ1 S O=999,DN=-8,DM=DM-1,DIL=DIL-1,DP=DP(DM),DX=+$S(DM:F(DM),1:0),F=$P(F,",",1,DM)_$E(",",DM>0),DY=DY(DM),DI=DI(DM)
I $D(DIL(DM)) S Y=" K J("_DIL0_"),I("_DIL0_")",DIL=DIL(DM),DIL0=DIL(DM,0) K DIL(DM) F X=DIL0:1 S %=X#100,V="I("_X_",0)",Y=Y_" S:$D("_V_") D"_%_"="_V I X=DIL G PX
Q
;
O ;
D DE,DN^DIL0
T ;
G PX:'$D(^UTILITY($J,99,DX))!DIO,PX:$L(^(DX))+$L(Y)+O>240 S ^(DX)=^(DX)_Y Q
;
DX(DX) ;If we're in sub-fields, another UTILITY node needs to invoke node DX
Q:'DM
N Y
S Y=F(DM-1) D IF S ^(Y)=^UTILITY($J,99,Y)_$S($T:",^UTILITY($J,99,",1:" X ^UTILITY($J,99,")_DX_")"
I $T,$L(^UTILITY($J,99,Y))>99 F O=500:1 I '$D(^(O)) S ^(Y)=$E(^(Y),1,$L(^(Y))-1-$L(DX))_O_")",F(DM-1)=O,^(O)="X ^UTILITY($J,99,"_DX_")" Q
Q
IF I ^UTILITY($J,99,Y)?.E1"^UTILITY($J,99,".N1")"
Q
DIL ;SFISC/GFT/XAK-TURN PRINT FLDS INTO CODE ;2DEC2002 [ 12/09/2003 4:09 PM ]
+1 ;;22.0;VA FileMan;**25,102,119,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
LOOP FOR DD=1:1
SET W=$PIECE(R,$CHAR(126),DD)
IF W=""
GOTO Q
IF DIWL
SET DIWL=9
DO DM
IF DIO
Begin DoDot:1
+1 SET DN=-8
IF DIO=1
QUIT
+2 IF DIO=3
DO UN
+3 SET DIWR(DM)=DX
SET Y=" D 0^DIWW"
DO PX
End DoDot:1
SET DIO=0
+4 ;
DM IF DM
IF $PIECE(W,F)]""
GOTO UP
SET W=$PIECE(W,F,2,999)
+1 IF W[";Y"
SET DE=""
IF DG
DO W
SET I=+$PIECE(W,";Y",2)
SET DG=0
SET Y=DE_" F Y=0:0 Q:$Y>"_$SELECT(I>0:I-2,1:"(IOSL"_(I-2)_")")_" W !"
IF I>0
SET M(DP)=I
DO PX
SET O=999
+2 IF 'W
GOTO ^DIL1
IF W?.NP1",".E
GOTO ^DIL11
IF $PIECE(W,";",1)'=+W
GOTO ^DIL1
KILL DPQ(DP,+W)
+3 DO DE
DO ^DIL0
IF DU=DN
GOTO T
IF $PIECE(X,U,2)["C"
SET DN=-2
GOTO PX
+4 SET DN=DU
SET Y=" S X=$G("_DI_C_DN_"))"_Y
PX ;
+1 IF DHT
IF DHT<0
GOTO PX^DIPZ1
SET ^UTILITY($JOB,DV)=$EXTRACT(Y,2,999)
SET Y=""
SET DV=DV+1
QUIT
+2 SET DX=DX+1
IF $DATA(^UTILITY($JOB,99,DX))
GOTO PX
SET ^(DX)=$EXTRACT(Y,2,999)
+3 DO DX(DX)
+4 SET O=0
Q QUIT
+1 ;
DE SET DE=""
IF W[";S"
IF DG
DO W
SET I=+$PIECE(W,";S",2)
SET DG=0
IF 'I
SET I=1
SET M(DP)=M(DP)+I
SET DE=DE_" D T Q:'DN "
FOR I=I:-1:1
SET DE=DE_" D N"
+1 IF $PIECE(W,";C",2)
SET DIC=$PIECE(W,";C",2)
IF DIC<0
SET DIC=IOM+DIC+1
IF DIC<DG
DO W
SET DG=DIC-1
IF 1
+2 IF DN=-4!$TEST
SET DE=DE_" D N:$X>"_DG_" Q:'DN "
+3 SET DE=DE_" W ?"_DG
QUIT
W ;
+1 IF $DATA(DIWR)
DO DIWR^DIL0
A ;
+1 KILL V
SET M(DP)=M(DP)+1
IF DHD
Begin DoDot:1
+2 SET I=99
SET V=""
FOR
SET V=$ORDER(^UTILITY("DIL",$JOB,V))
IF V=""
QUIT
SET Z=$ORDER(^(V,0))
IF I>Z
SET I=Z
+3 FOR I=I:1:99
SET Z="W !"
Begin DoDot:2
+4 SET V=""
FOR
SET V=$ORDER(^UTILITY("DIL",$JOB,V))
IF V=""
QUIT
IF $DATA(^(V,I))
SET %=$GET(^($ORDER(^(0))-I+99))
Begin DoDot:3
+5 FOR
IF %'?1" ".E
QUIT
SET V=V+1
SET %=$EXTRACT(%,2,999)
+6 IF $LENGTH(Z)+$LENGTH(%)>245
DO U
+7 SET Z=Z_",?"_V_","""_%_""""
End DoDot:3
End DoDot:2
IF Z'="W !"
DO U
End DoDot:1
+8 KILL ^UTILITY("DIL",$JOB)
QUIT
+9 ;
U SET ^UTILITY($JOB,DHD)=Z
SET DHD=DHD+1
SET Z="W """""
QUIT
+1 ;
D ;
+1 IF DHT<1
DO PX
SET F(DM)=DX
SET R(DX)=DP(DM)
SET R(DX,1)=M(DP(DM))
SET F=F_W_","
SET DM=DM+1
SET DIL=DIL+1
SET DD=DD-1
IF DHT+1
SET DX=$SELECT('DHT:900,1:DX)
IF DHT
DO PX
QUIT
+2 GOTO DE^DIPZ1
+3 ;
UP DO UN
GOTO DM
+1 ;
UNSTACK ;
+1 DO UN
IF 'DM
QUIT
GOTO UNSTACK
+2 ;
UN ;
+1 IF $DATA(DIWR(DM))
DO DIWR^DIL0
+2 IF DHT<0
DO UP^DIPZ1
SET O=999
SET DN=-8
SET DM=DM-1
SET DIL=DIL-1
SET DP=DP(DM)
SET DX=+$SELECT(DM:F(DM),1:0)
SET F=$PIECE(F,",",1,DM)_$EXTRACT(",",DM>0)
SET DY=DY(DM)
SET DI=DI(DM)
+3 IF $DATA(DIL(DM))
SET Y=" K J("_DIL0_"),I("_DIL0_")"
SET DIL=DIL(DM)
SET DIL0=DIL(DM,0)
KILL DIL(DM)
FOR X=DIL0:1
SET %=X#100
SET V="I("_X_",0)"
SET Y=Y_" S:$D("_V_") D"_%_"="_V
IF X=DIL
GOTO PX
+4 QUIT
+5 ;
O ;
+1 DO DE
DO DN^DIL0
T ;
+1 IF '$DATA(^UTILITY($JOB,99,DX))!DIO
GOTO PX
IF $LENGTH(^(DX))+$LENGTH(Y)+O>240
GOTO PX
SET ^(DX)=^(DX)_Y
QUIT
+2 ;
DX(DX) ;If we're in sub-fields, another UTILITY node needs to invoke node DX
+1 IF 'DM
QUIT
+2 NEW Y
+3 SET Y=F(DM-1)
DO IF
SET ^(Y)=^UTILITY($JOB,99,Y)_$SELECT($TEST:",^UTILITY($J,99,",1:" X ^UTILITY($J,99,")_DX_")"
+4 IF $TEST
IF $LENGTH(^UTILITY($JOB,99,Y))>99
FOR O=500:1
IF '$DATA(^(O))
SET ^(Y)=$EXTRACT(^(Y),1,$LENGTH(^(Y))-1-$LENGTH(DX))_O_")"
SET F(DM-1)=O
SET ^(O)="X ^UTILITY($J,99,"_DX_")"
QUIT
+5 QUIT
IF IF ^UTILITY($JOB,99,Y)?.E1"^UTILITY($J,99,".N1")"
+1 QUIT
