DIL ;SFISC/GFT/XAK-TURN PRINT FLDS INTO CODE ;31DEC2003
;;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.
;
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 ;FROM DIP5 AND DIPZ & above
S M(DP)=M(DP)+1 I DHD D COLHEADS(.DHD)
I $D(DIOSUBHD) S:DIOSUBHD<2 DIOSUBHD=2 D COLHEADS(.DIOSUBHD)
Q
;
;
COLHEADS(DHD) ;TAKE COLUMN HEADERS AND STORE THEM AS WRITE STATEMENTS, STARTING AT ^UTILITY($J,DHD)
N V,I,Z,%
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
;
;
SUBHEADS ;
N X
S X=$$EZBLD^DIALOG(7095) ;"PAGE"
W:$X+30>IOM !
W ?IOM-30,$$NOW^DIUTL," "
I $G(DC) W ?IOM-$L(X)-4,X," ",DC
F X=1.5:0 S X=$O(^UTILITY($J,X)) Q:X>50!'X X ^(X)
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIL 3219 printed Sep 23, 2025@20:25:21 Page 2
DIL ;SFISC/GFT/XAK-TURN PRINT FLDS INTO CODE ;31DEC2003
+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 ;
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 ;FROM DIP5 AND DIPZ & above
+1 SET M(DP)=M(DP)+1
IF DHD
DO COLHEADS(.DHD)
+2 IF $DATA(DIOSUBHD)
if DIOSUBHD<2
SET DIOSUBHD=2
DO COLHEADS(.DIOSUBHD)
+3 QUIT
+4 ;
+5 ;
COLHEADS(DHD) ;TAKE COLUMN HEADERS AND STORE THEM AS WRITE STATEMENTS, STARTING AT ^UTILITY($J,DHD)
+1 NEW V,I,Z,%
+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:1
+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:2
+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:2
End DoDot:1
IF Z'="W !"
DO U
+8 KILL ^UTILITY("DIL",$JOB)
+9 QUIT
U SET ^UTILITY($JOB,DHD)=Z
SET DHD=DHD+1
SET Z="W """""
QUIT
+1 ;
+2 ;
SUBHEADS ;
+1 NEW X
+2 ;"PAGE"
SET X=$$EZBLD^DIALOG(7095)
+3 if $X+30>IOM
WRITE !
+4 WRITE ?IOM-30,$$NOW^DIUTL," "
+5 IF $GET(DC)
WRITE ?IOM-$LENGTH(X)-4,X," ",DC
+6 FOR X=1.5:0
SET X=$ORDER(^UTILITY($JOB,X))
if X>50!'X
QUIT
XECUTE ^(X)
+7 QUIT
+8 ;
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
