- DIL0 ;SFISC/GFT - TURN PRINT FLDS INTO CODE ;4NOV2016
- ;;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;**91,102,999,1005,1012,1056**
- ;CALLED FROM ^DIL
- D XDUY S %=$P(X,U,2) S:%["Cm"&(W[";W") %="w"_% G WP:%["W",M:%["m",STATS^DIL1:$D(DCL(DP_U_+W)),N:W[";N"
- I W[";W" D S D1=$S(%["C":Y,1:$P(" S Y=",U,Y'?1" ".E)_Y_" S X=Y") D W S Y=Y_D1_" D ^DIWP" Q
- .N %,DNP S DNP=1 D EN^DILL(DP,+W,1)
- D EN^DILL(DP,+W,1)
- DN ;
- I W[";X" D Q
- .S DE=$S(W[";C"!(W[";S"):DE,$A(Y)-32:" W ?0",1:"")
- .I $L(DE)+$L(Y)>250 D
- ..S %=Y,Y=DE,DE=% D PX^DIL S Y=DE
- .E S Y=DE_Y
- .I $D(DIWR(DM)) D DIWR
- DNW D H:DHD!$G(DIOSUBHD) I DG+DLN>IOM,DG K ^UTILITY("DIL",$J,DG) S DG='%*DM*2+2,DE=$P(W,";C",2),DG=$S(DE>0:DE-1,DE<0:IOM+DE,DG+DLN'>IOM!(W[";W"):DG,DLN>IOM:0,1:IOM-DLN),DE=" D T Q:'DN W ?"_DG D W^DIL,H:DHD!$G(DIOSUBHD)
- S DG=2+DLN+DG Q:$D(DNP) I $L(DE)+$L(Y)>250 S %=Y,Y=DE,DE=% D PX^DIL S Y=DE Q
- S Y=DE_Y Q
- ;
- H S V=$P(X,U),Z=99,I=$F(W,";""") I I>0 Q:$E(W,I-4,I)=";Z;""""" S I=$P(W,";""",2),V=$$CONVQQ^DILIBF($P(I,"""",1,$L(I,"""")-1)) ;V will be COLUMN HEADER
- HEAD Q:V="" S I=$P(V," ") I $L(I)>DLN S DLN=$L(I) ;Grab the next 'word'. Column width may have to be increased for a long word
- XD S V=$P(V," ",2,99),D=$P(V," ") I D]"",$L(I)+$L(D)<DLN S I=I_" "_D G XD
- S ^UTILITY("DIL",$J,DG,Z)=$J(I,DRJ*DLN),V(Z)="",Z=Z-1 G HEAD
- ;
- XDUY ;
- I '$D(^DD(DP,+W,0)) S X="",DU=0,Y=0 Q
- S X=^(0),DU=$P(X,U,4),Y=$P(DU,";",2),DU=$P(DU,";") I W[";T",$D(^(.1)) S X=^(.1)_U_$P(X,U,2,99)
- EGP E S $P(X,U)=$$LABEL^DIALOGZ(DP,+W) ;**FIELD LABEL FOR OUTPUT HEADING
- S:+DU'=DU DU=""""_DU_""""
- I Y S Y="$P(X,U,"_Y_")" Q
- I Y="" S Y="D"_DM Q
- S Y=$E(Y,2,9) S:$P(Y,",",2)=+Y Y=+Y S Y="$E(X,"_Y_")" Q
- ;
- WR ;
- K DLN D W^DILL
- W S DRJ=0,DIWL=DIWL+1 I '$D(DLN) S %=IOM-DG,DLN=$S(%>20:%,1:IOM)-2
- S:W[";X" $P(X,U)="" D DNW S %=$P(DE,"W ?",2)+1,Y=DLN+%-1,DIO=2,%=" S DIWL="_%_",DIWR="_$S(IOM<Y:IOM,1:Y),Y=$P(DE," W ?")_% Q
- ;
- WP S DN=%["L"_U D WR ;COME HERE FOR A W-P TYPE FIELD
- S DIO=3,Y=%_" D ^DIWP",X=F(DM-1) I DHT<0 S I=$E(^UTILITY("DIPZ",$J,X),2,999) D WPX S ^UTILITY("DIPZ",$J,X)=" "_I Q
- I $D(^UTILITY($J,99,X)) S I=^(X) D WPX S ^UTILITY($J,99,X)=I Q
- WPX ;from DIPZ1
- S:DN I=^DD("FUNC",38,1)_" "_I ;'NOWRAP' FUNCTION
- I DE]"" S I=DE_" "_I ;GFT
- Q
- ;
- M S D1=" S DICMX=""D "_$E("L",%'["w")_"^DIWP"" "_$P(X,U,5,99) D WR S Y=Y_D1 Q
- ;
- N ;
- S DCL=DCL+1,DXS="Y",D=",Y=$$DITTO^DIO2("_DCL_",Y)",DITTO(DCL)="",I=""
- I %["C" S X=X_" S Y=X"_D_" S X=Y" G Z
- S Y=" S Y="_Y_D
- Z D EN^DILL(DP,+W) G DN
- ;
- DIWR ;CALLED FROM ^DIL
- G DIWR^DIPZ1:DHT I $D(DIWR(DM)),DX=DIWR(DM) S ^UTILITY($J,99,DX)="D A^DIWW" G K
- I $D(DIWR(DM)) F DX=DX+1:1 I '$D(^UTILITY($J,99,DX)) S ^(DX)="D ^DIWW" D DX^DIL(DX) G K
- D S ^UTILITY($J,99,I)="D ^DIWW "_^UTILITY($J,99,I)
- .F I=DM-1:-1:0 I $D(DIWR(I)) K DIWR(I) Q
- .I I S I=F(I)
- .E F I=1:1 Q:'$D(^UTILITY($J,99,I+1))
- K K DIWR(DM) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIL0 3134 printed Dec 13, 2024@02:49:16 Page 2
- DIL0 ;SFISC/GFT - TURN PRINT FLDS INTO CODE ;4NOV2016
- +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;**91,102,999,1005,1012,1056**
- +7 ;CALLED FROM ^DIL
- +8 DO XDUY
- SET %=$PIECE(X,U,2)
- if %["Cm"&(W[";W")
- SET %="w"_%
- if %["W"
- GOTO WP
- if %["m"
- GOTO M
- if $DATA(DCL(DP_U_+W))
- GOTO STATS^DIL1
- if W[";N"
- GOTO N
- +9 IF W[";W"
- Begin DoDot:1
- +10 NEW %,DNP
- SET DNP=1
- DO EN^DILL(DP,+W,1)
- End DoDot:1
- SET D1=$SELECT(%["C":Y,1:$PIECE(" S Y=",U,Y'?1" ".E)_Y_" S X=Y")
- DO W
- SET Y=Y_D1_" D ^DIWP"
- QUIT
- +11 DO EN^DILL(DP,+W,1)
- DN ;
- +1 IF W[";X"
- Begin DoDot:1
- +2 SET DE=$SELECT(W[";C"!(W[";S"):DE,$ASCII(Y)-32:" W ?0",1:"")
- +3 IF $LENGTH(DE)+$LENGTH(Y)>250
- Begin DoDot:2
- +4 SET %=Y
- SET Y=DE
- SET DE=%
- DO PX^DIL
- SET Y=DE
- End DoDot:2
- +5 IF '$TEST
- SET Y=DE_Y
- +6 IF $DATA(DIWR(DM))
- DO DIWR
- End DoDot:1
- QUIT
- DNW if DHD!$GET(DIOSUBHD)
- DO H
- IF DG+DLN>IOM
- IF DG
- KILL ^UTILITY("DIL",$JOB,DG)
- SET DG='%*DM*2+2
- SET DE=$PIECE(W,";C",2)
- SET DG=$SELECT(DE>0:DE-1,DE<0:IOM+DE,DG+DLN'>IOM!(W[";W"):DG,DLN>IOM:0,1:IOM-DLN)
- SET DE=" D T Q:'DN W ?"_DG
- DO W^DIL
- if DHD!$GET(DIOSUBHD)
- DO H
- +1 SET DG=2+DLN+DG
- if $DATA(DNP)
- QUIT
- IF $LENGTH(DE)+$LENGTH(Y)>250
- SET %=Y
- SET Y=DE
- SET DE=%
- DO PX^DIL
- SET Y=DE
- QUIT
- +2 SET Y=DE_Y
- QUIT
- +3 ;
- H ;V will be COLUMN HEADER
- SET V=$PIECE(X,U)
- SET Z=99
- SET I=$FIND(W,";""")
- IF I>0
- if $EXTRACT(W,I-4,I)=";Z;"""""
- QUIT
- SET I=$PIECE(W,";""",2)
- SET V=$$CONVQQ^DILIBF($PIECE(I,"""",1,$LENGTH(I,"""")-1))
- HEAD ;Grab the next 'word'. Column width may have to be increased for a long word
- if V=""
- QUIT
- SET I=$PIECE(V," ")
- IF $LENGTH(I)>DLN
- SET DLN=$LENGTH(I)
- XD SET V=$PIECE(V," ",2,99)
- SET D=$PIECE(V," ")
- IF D]""
- IF $LENGTH(I)+$LENGTH(D)<DLN
- SET I=I_" "_D
- GOTO XD
- +1 SET ^UTILITY("DIL",$JOB,DG,Z)=$JUSTIFY(I,DRJ*DLN)
- SET V(Z)=""
- SET Z=Z-1
- GOTO HEAD
- +2 ;
- XDUY ;
- +1 IF '$DATA(^DD(DP,+W,0))
- SET X=""
- SET DU=0
- SET Y=0
- QUIT
- +2 SET X=^(0)
- SET DU=$PIECE(X,U,4)
- SET Y=$PIECE(DU,";",2)
- SET DU=$PIECE(DU,";")
- IF W[";T"
- IF $DATA(^(.1))
- SET X=^(.1)_U_$PIECE(X,U,2,99)
- EGP ;**FIELD LABEL FOR OUTPUT HEADING
- IF '$TEST
- SET $PIECE(X,U)=$$LABEL^DIALOGZ(DP,+W)
- +1 if +DU'=DU
- SET DU=""""_DU_""""
- +2 IF Y
- SET Y="$P(X,U,"_Y_")"
- QUIT
- +3 IF Y=""
- SET Y="D"_DM
- QUIT
- +4 SET Y=$EXTRACT(Y,2,9)
- if $PIECE(Y,",",2)=+Y
- SET Y=+Y
- SET Y="$E(X,"_Y_")"
- QUIT
- +5 ;
- WR ;
- +1 KILL DLN
- DO W^DILL
- W SET DRJ=0
- SET DIWL=DIWL+1
- IF '$DATA(DLN)
- SET %=IOM-DG
- SET DLN=$SELECT(%>20:%,1:IOM)-2
- +1 if W[";X"
- SET $PIECE(X,U)=""
- DO DNW
- SET %=$PIECE(DE,"W ?",2)+1
- SET Y=DLN+%-1
- SET DIO=2
- SET %=" S DIWL="_%_",DIWR="_$SELECT(IOM<Y:IOM,1:Y)
- SET Y=$PIECE(DE," W ?")_%
- QUIT
- +2 ;
- WP ;COME HERE FOR A W-P TYPE FIELD
- SET DN=%["L"_U
- DO WR
- +1 SET DIO=3
- SET Y=%_" D ^DIWP"
- SET X=F(DM-1)
- IF DHT<0
- SET I=$EXTRACT(^UTILITY("DIPZ",$JOB,X),2,999)
- DO WPX
- SET ^UTILITY("DIPZ",$JOB,X)=" "_I
- QUIT
- +2 IF $DATA(^UTILITY($JOB,99,X))
- SET I=^(X)
- DO WPX
- SET ^UTILITY($JOB,99,X)=I
- QUIT
- WPX ;from DIPZ1
- +1 ;'NOWRAP' FUNCTION
- if DN
- SET I=^DD("FUNC",38,1)_" "_I
- +2 ;GFT
- IF DE]""
- SET I=DE_" "_I
- +3 QUIT
- +4 ;
- M SET D1=" S DICMX=""D "_$EXTRACT("L",%'["w")_"^DIWP"" "_$PIECE(X,U,5,99)
- DO WR
- SET Y=Y_D1
- QUIT
- +1 ;
- N ;
- +1 SET DCL=DCL+1
- SET DXS="Y"
- SET D=",Y=$$DITTO^DIO2("_DCL_",Y)"
- SET DITTO(DCL)=""
- SET I=""
- +2 IF %["C"
- SET X=X_" S Y=X"_D_" S X=Y"
- GOTO Z
- +3 SET Y=" S Y="_Y_D
- Z DO EN^DILL(DP,+W)
- GOTO DN
- +1 ;
- DIWR ;CALLED FROM ^DIL
- +1 if DHT
- GOTO DIWR^DIPZ1
- IF $DATA(DIWR(DM))
- IF DX=DIWR(DM)
- SET ^UTILITY($JOB,99,DX)="D A^DIWW"
- GOTO K
- +2 IF $DATA(DIWR(DM))
- FOR DX=DX+1:1
- IF '$DATA(^UTILITY($JOB,99,DX))
- SET ^(DX)="D ^DIWW"
- DO DX^DIL(DX)
- GOTO K
- +3 Begin DoDot:1
- +4 FOR I=DM-1:-1:0
- IF $DATA(DIWR(I))
- KILL DIWR(I)
- QUIT
- +5 IF I
- SET I=F(I)
- +6 IF '$TEST
- FOR I=1:1
- if '$DATA(^UTILITY($JOB,99,I+1))
- QUIT
- End DoDot:1
- SET ^UTILITY($JOB,99,I)="D ^DIWW "_^UTILITY($JOB,99,I)
- K KILL DIWR(DM)
- QUIT