- 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
