- DIL11 ;SFISC/GFT - TURN PRINT FLDS INTO CODE ;10NOV2016
- ;;22.2;VA FileMan;**4**;Jan 05, 2016;Build 5
- ;;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.
- ;;GFT;**152,1037,1056**
- ;
- DOWN ;INTO A MULTIPLE
- I W>0,'$D(^DD(DP,+W,0)) Q ;IN CASE FIELD IS NOW GONE FOR SOME REASON!
- S DN=-6,DY(DM)=DY,DP(DM)=DP,DI(DM)=DI I W>0 D M G D^DIL
- F ;
- S DP=-W,X=$P(W,U,2),DD=DD+1,M(DP)=1,DIL(DM)=DIL,DIL(DM,0)=DIL0,Y=0,DIL0=DIL0+100,%=X["(" I % S (X,DI)=U_X,DIL=DIL0
- E S DI=DI(DM)_","""_X_""",",DIL=DIL+101
- QT S Y=$F(X,"""",Y) I Y S X=$E(X,1,Y-1)_$E(X,Y-1,999),Y=Y+1 G QT
- S Y=" S I("_DIL_")="""_X_""",J("_DIL_")="_DP
- S X=" "_$P($P(W,U,4,99),";")
- S DY="D"_(DIL-DIL0),DI=DI_DY,DIL=DIL-1 I $P(W,U,3)="" S W=+W,Y=Y_X_" S D0=D(0) I D0>0" G D^DIL
- S %="I("_(DIL0-100)_",0)=D0" I X'[% S X=","_%_X
- I DHT=-1 D DREL^DIPZ1 G END ;WE'RE COMPILING A PRINT TEMPLATE
- F %=900:1 I '$D(^UTILITY($J,99,%)) S ^(%)="I 1 X:$D(DSC("_DP_")) DSC("_DP_") I D T:$X>"_DG_" Q:'DN "_Y,Y=" S (DIXX,DIXX("_(DM+1)_"))="_%_X,W=+W D D^DIL K R(DX) Q
- END S (F(DM-1),DX)=%,R(%)=DP(DM-1),R(%,1)=M(DP(DM-1))
- Q
- ;
- ;
- M N %,DILEVEL,DIB1,DIBO,D,DY,X ;BUILD A "Y" STRING
- S DILEVEL=DIL-DIL0+1
- S X=^DD(DP,+W,0),DU=$P($P(X,U,4),";") S:+DU'=DU DU=""""_DU_""""
- S DI=DI_","_DU_",",DY="D"_DILEVEL
- B I W'[";B" S %=":0 Q:$O("_DI_DY_"))'>0 ",DIB1=""
- E S DIB1="DIB"_DIL,DIBO="$O("_DI_"""B"","_DIB1,DIB1=" N "_DIB1_" S "_DIB1_"="""" F S "_DIB1_"="_DIBO_")) Q:"_DIB1_"="""" Q:'DN ",%=":0 Q:"_DIBO_","_DY_"))'>0 "
- S DI=DI_DY
- S DP=+$P(X,U,2),M(DP)=1,D=$P("""""",U,+DU'=DU),D=" S I("_(DIL+1)_")="_D_DU_D_",J("_(DIL+1)_")="_DP_DIB1,Y=" S "_DY_"=$O(^("_DY_"))"
- ;XML I $G(DDXPFFNO) S D=D_$$WOPEN^DIXML($P(X,U))
- ;
- W S W=$P(W,",") I $P(^DD(DP,.01,0),U,2)["W" D:$P(^(0),U,2)["x"!($P(^(0),U,2)["X") G P ;**DI*22*152**
- .S D=D_",D"_(DIL+1)_"=$G(DIWF) N DIWF S DIWF=D"_(DIL+1)_"_""X"""
- I DHT+1 F X=1:1 G P:X>DPP,DPP:+DPP(X)=DP!$D(DPP(X,DP))
- DPP S Y=Y_" Q:"_DY_"'>0 "
- I DIB1="" S Y=" X $G(DSC("_DP_")) "_Y ;DSC will switch the naked reference, so we can get thru the subentries faster!
- I DIB1]"" S Y=Y_" I 1 X $G(DSC("_DP_")) I " ;DSC will do an IF
- I DHT+1,"@"[$P(DPP(X),U,4),$P(DPP(X),U,2)=0 S DPP(X,U)="" G R:$D(DPP(X,"F"))
- S Y=Y_" "
- P S Y=D_" F "_DY_"=0"_%_Y_$S($D(DIARP(DP)):" X DIARP("_DP_") I $T",1:"")
- G S
- ;
- R S V=$P(DPP(X,"T"),U),Y=D_" F "_DY_"="_$P(DPP(X,"F"),U)_%_Y ;RANGE "F"ROM AND "T"O SORTING BY SUB-IEN
- I V S:Y?.E1"'>0 " Y=$E(Y,1,$L(Y)-1) S Y=Y_"!("_DY_">"_V_")" ;_$S(V:"!("_DY_">"_V_") ",1:" ")
- S Y=Y_" "
- S S:($G(DDXP)'=4) %=" D:$X>"_DG,Y=Y_%_$S($D(DIWR):" NX^DIWW",1:" T Q:'DN ") ;ADD A LINE FEED UNLESS WE ARE 'EXPORTING'
- I DHT>0 S ^UTILITY($J,DV)="I "_DY_"'>0 S "_DY_"=0 "_$P(Y," ",2,99),DV=DV+1 ;HEADER TEMPLATE
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIL11 2943 printed Mar 13, 2025@21:54:03 Page 2
- DIL11 ;SFISC/GFT - TURN PRINT FLDS INTO CODE ;10NOV2016
- +1 ;;22.2;VA FileMan;**4**;Jan 05, 2016;Build 5
- +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 ;;GFT;**152,1037,1056**
- +7 ;
- DOWN ;INTO A MULTIPLE
- +1 ;IN CASE FIELD IS NOW GONE FOR SOME REASON!
- IF W>0
- IF '$DATA(^DD(DP,+W,0))
- QUIT
- +2 SET DN=-6
- SET DY(DM)=DY
- SET DP(DM)=DP
- SET DI(DM)=DI
- IF W>0
- DO M
- GOTO D^DIL
- F ;
- +1 SET DP=-W
- SET X=$PIECE(W,U,2)
- SET DD=DD+1
- SET M(DP)=1
- SET DIL(DM)=DIL
- SET DIL(DM,0)=DIL0
- SET Y=0
- SET DIL0=DIL0+100
- SET %=X["("
- IF %
- SET (X,DI)=U_X
- SET DIL=DIL0
- +2 IF '$TEST
- SET DI=DI(DM)_","""_X_""","
- SET DIL=DIL+101
- QT SET Y=$FIND(X,"""",Y)
- IF Y
- SET X=$EXTRACT(X,1,Y-1)_$EXTRACT(X,Y-1,999)
- SET Y=Y+1
- GOTO QT
- +1 SET Y=" S I("_DIL_")="""_X_""",J("_DIL_")="_DP
- +2 SET X=" "_$PIECE($PIECE(W,U,4,99),";")
- +3 SET DY="D"_(DIL-DIL0)
- SET DI=DI_DY
- SET DIL=DIL-1
- IF $PIECE(W,U,3)=""
- SET W=+W
- SET Y=Y_X_" S D0=D(0) I D0>0"
- GOTO D^DIL
- +4 SET %="I("_(DIL0-100)_",0)=D0"
- IF X'[%
- SET X=","_%_X
- +5 ;WE'RE COMPILING A PRINT TEMPLATE
- IF DHT=-1
- DO DREL^DIPZ1
- GOTO END
- +6 FOR %=900:1
- IF '$DATA(^UTILITY($JOB,99,%))
- SET ^(%)="I 1 X:$D(DSC("_DP_")) DSC("_DP_") I D T:$X>"_DG_" Q:'DN "_Y
- SET Y=" S (DIXX,DIXX("_(DM+1)_"))="_%_X
- SET W=+W
- DO D^DIL
- KILL R(DX)
- QUIT
- END SET (F(DM-1),DX)=%
- SET R(%)=DP(DM-1)
- SET R(%,1)=M(DP(DM-1))
- +1 QUIT
- +2 ;
- +3 ;
- M ;BUILD A "Y" STRING
- NEW %,DILEVEL,DIB1,DIBO,D,DY,X
- +1 SET DILEVEL=DIL-DIL0+1
- +2 SET X=^DD(DP,+W,0)
- SET DU=$PIECE($PIECE(X,U,4),";")
- if +DU'=DU
- SET DU=""""_DU_""""
- +3 SET DI=DI_","_DU_","
- SET DY="D"_DILEVEL
- B IF W'[";B"
- SET %=":0 Q:$O("_DI_DY_"))'>0 "
- SET DIB1=""
- +1 IF '$TEST
- SET DIB1="DIB"_DIL
- SET DIBO="$O("_DI_"""B"","_DIB1
- SET DIB1=" N "_DIB1_" S "_DIB1_"="""" F S "_DIB1_"="_DIBO_")) Q:"_DIB1_"="""" Q:'DN "
- SET %=":0 Q:"_DIBO_","_DY_"))'>0 "
- +2 SET DI=DI_DY
- +3 SET DP=+$PIECE(X,U,2)
- SET M(DP)=1
- SET D=$PIECE("""""",U,+DU'=DU)
- SET D=" S I("_(DIL+1)_")="_D_DU_D_",J("_(DIL+1)_")="_DP_DIB1
- SET Y=" S "_DY_"=$O(^("_DY_"))"
- +4 ;XML I $G(DDXPFFNO) S D=D_$$WOPEN^DIXML($P(X,U))
- +5 ;
- W ;**DI*22*152**
- SET W=$PIECE(W,",")
- IF $PIECE(^DD(DP,.01,0),U,2)["W"
- if $PIECE(^(0),U,2)["x"!($PIECE(^(0),U,2)["X")
- Begin DoDot:1
- +1 SET D=D_",D"_(DIL+1)_"=$G(DIWF) N DIWF S DIWF=D"_(DIL+1)_"_""X"""
- End DoDot:1
- GOTO P
- +2 IF DHT+1
- FOR X=1:1
- if X>DPP
- GOTO P
- if +DPP(X)=DP!$DATA(DPP(X,DP))
- GOTO DPP
- DPP SET Y=Y_" Q:"_DY_"'>0 "
- +1 ;DSC will switch the naked reference, so we can get thru the subentries faster!
- IF DIB1=""
- SET Y=" X $G(DSC("_DP_")) "_Y
- +2 ;DSC will do an IF
- IF DIB1]""
- SET Y=Y_" I 1 X $G(DSC("_DP_")) I "
- +3 IF DHT+1
- IF "@"[$PIECE(DPP(X),U,4)
- IF $PIECE(DPP(X),U,2)=0
- SET DPP(X,U)=""
- if $DATA(DPP(X,"F"))
- GOTO R
- +4 SET Y=Y_" "
- P SET Y=D_" F "_DY_"=0"_%_Y_$SELECT($DATA(DIARP(DP)):" X DIARP("_DP_") I $T",1:"")
- +1 GOTO S
- +2 ;
- R ;RANGE "F"ROM AND "T"O SORTING BY SUB-IEN
- SET V=$PIECE(DPP(X,"T"),U)
- SET Y=D_" F "_DY_"="_$PIECE(DPP(X,"F"),U)_%_Y
- +1 ;_$S(V:"!("_DY_">"_V_") ",1:" ")
- IF V
- if Y?.E1"'>0 "
- SET Y=$EXTRACT(Y,1,$LENGTH(Y)-1)
- SET Y=Y_"!("_DY_">"_V_")"
- +2 SET Y=Y_" "
- S ;ADD A LINE FEED UNLESS WE ARE 'EXPORTING'
- if ($GET(DDXP)'=4)
- SET %=" D:$X>"_DG
- SET Y=Y_%_$SELECT($DATA(DIWR):" NX^DIWW",1:" T Q:'DN ")
- +1 ;HEADER TEMPLATE
- IF DHT>0
- SET ^UTILITY($JOB,DV)="I "_DY_"'>0 S "_DY_"=0 "_$PIECE(Y," ",2,99)
- SET DV=DV+1
- +2 QUIT
