DIBT ;SFISC/GFT,TKW,TOAD-STORE A SORT TEMPLATE ;8SEP2014
;;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.
;
0 ; select and edit templates, until user quits
S DIC="^DOPT(""DIBT"",",DICF=DI
I '$D(^DOPT("DIBT",.402)) S ^(0)="TEMPLATE FILE^1.01" K ^("B") D
.F X=.4,.401,.402 S ^DOPT("DIBT",X,0)=$P(^DIC(X,0),U)
.N DIK S DIK=DIC D IXALL^DIK
S DIC(0)="QEAIN",DIC("A")="Select TEMPLATE File: "
S DIC("S")="I Y=.4!(Y=.401)!(Y=.402)"
D ^DIC K DIC Q:Y<0
K DTOUT F Q:'$$T(+Y,DICF) I $D(DTOUT) K DTOUT Q
Q
;
T(DDSFILE,DICF) ;=.4,.401,.402
N Y,DIC,DIERR,DDSPARM,DR,DA,DIN
W !! S DIC=DDSFILE,DIC("S")="I $P(^(0),U,4)="_DICF_",Y'<1",D="F"_DICF
S DIC(0)="AEQI" D IX^DIC I Y<0 Q 0
S DA=+Y,DIN=$$SCREEN G SCROLL:DIN=0 I 'DIN Q 0
S DIN=$S(DDSFILE=.4:"DIPTED",DDSFILE=.402:"DIETED",1:"DIBTED")
S DR="["_DIN_"]",DDSPARM="" D ^DDS Q '$D(DIERR)
;
SCROLL N DIE,DIOVRD,DR
S DIE=DDSFILE,DR=".01:3;5:7;10;21409;707;491620",DIOVRD=1 D ^DIE Q 1 ;TRICK: NOT EVERY ONE OF THE 3 TEMPLATE FILES HAS ALL THESE FIELDS
;
SCREEN(HELP) ;
N DIR,DIRUT,DUOUT,X,Y,DIERR
K DUZ("SCREEN") ;COMMENT OUT THIS LINE IF YOU WANT FILEMAN TO REMEMBER!
I $G(DUZ("SCREEN"))=0 Q 0
D SET^DDGLIB0 I $D(DIERR) Q 0
I '$G(DUZ("SCREEN")) D I '$D(DUZ("SCREEN")) Q U ;ABORT
.S DIR(0)="Y",DIR("A")="Do you want to use the screen-mode version",DIR("B")="YES"
.I $D(HELP) S DIR("?")=HELP
.D ^DIR I Y-1 S:Y=0 DUZ("SCREEN")=0 Q
.S DUZ("SCREEN")=1
D KILL^DDGLIB0()
;I ^DD("OS")=9 U $I:VT=1 ;FOR DATATREE
Q +$G(DUZ("SCREEN"))
;
;
;
S ;
D S1^DIBT1 K DIRUT,DIROUT G Q^DIP:$D(DUOUT)!($D(DTOUT))
G N:X="",S:Y<0
S DIBT1=+Y
SNEW ;COME HERE FROM DIP1
K ^DIBT(DIBT1,2),^("BY0"),^("BY0D") S $P(^DIBT(DIBT1,0),U,7)=DT
I $G(BY(0))]"",$D(DPP(0)) D
. N DIBY,DIREC,%,I,D,F,T,Q1,Q2,O S %=DIBT1_"," S DIBY(.401,%,1622)=$P(BY(0),U,2),DIBY(.401,%,1623)=DPP(0)+1 D FILE^DIE("E","DIBY")
. F I=1:1:DPP(0) D
.. S F=$P($G(DPP(I,"F")),U,2),T=$P($G(DPP(I,"T")),U,2),O=$P($G(DPP(I)),U,4),Q1="" S:O["!" Q1=Q1_"!" S:O["#" Q1=Q1_"#" S Q2=$P($G(DPP(I)),U,5),O=$G(DPP(I,"OUT"))
.. S %="+"_I_","_DIBT1_"," K DIBY(.4011624,%)
.. S:F]"" DIBY(.4011624,%,1)=F S:T]"" DIBY(.4011624,%,2)=T S:Q1]"" DIBY(.4011624,%,3.1)=Q1 S:Q2]"" DIBY(.4011624,%,3.2)=Q2 S:O]"" DIBY(.4011624,%,4)=O
.. Q:'$D(DIBY(.4011624,%)) S DIBY(.4011624,%,.01)=I,DIREC(I)=I Q
. D UPDATE^DIE("E","DIBY","DIREC")
. Q
S (DIBT2,DIBT3)=+$G(DPP(0)) F S DIBT3=$O(DPP(DIBT3)) Q:'DIBT3 S DIBT2=DIBT2+1 D ;LOOP THRU THE SORT LEVELS
.N DIC,DA,DIE,DINUM,DIOVRD,DR,DO S X=$P(DPP(DIBT3),U) Q:+$P(X,"E")'=X S DIC="^DIBT("_DIBT1_",2,",DIC(0)="L",DA(1)=DIBT1,DINUM=DIBT2,DIOVRD=1,DIC("P")=$P(^DD(.401,1621,0),U,2) D FILE^DICN K DIC,DA,DINUM,DIOVRD
.N A,B,C,D S $P(^DIBT(DIBT1,2,DIBT2,0),U,2,10)=$P(DPP(DIBT3),U,2,10)
EGP .I $D(DPP(DIBT3,"LANG"))=11 S $P(^(0),U,3)=DPP(DIBT3,"LANG") ;**CCO/NI PUT THE CORRECT NAME INTO STORED TEMPLATE
.S A="A" F S A=$O(DPP(DIBT3,A)) Q:A="" D
..S %=$G(DPP(DIBT3,A)) I %]"",(A'="TXT")!($G(DUZ("LANG"))'>1) D ;SAVE STUFF FROM DPP, BUT DON'T SAVE FURRIN-LANGUAGE 'TEXT'
...S ^DIBT(DIBT1,2,DIBT2,A)=%
...I A["COMPUTED" M ^DIBT(DIBT1,2,DIBT2,A)=DPP(DIBT3,A)
.S (C,D)=0 F A=-1:0 S A=$O(DPP(DIBT3,A)) Q:+$P(A,"E")'=A D
..I $G(DPP(DIBT3,A))]"" S C=C+1,%=1,%(1)=17,X=A,DINUM=C,DIC("DR")="1////"_DPP(DIBT3,A) D DICM
..S B="" F S B=$O(DPP(DIBT3,A,B)) Q:B="" S D=D+1,%=2,%(1)=18,X=A,DINUM=D D DICM S:Y>0 ^DIBT(DIBT1,2,DIBT2,2,+Y,"RCOD")=$P(DPP(DIBT3,A,B),U,4,99)
..Q
.S D=0,A="OV" F S A=$O(DPP(DIBT3,A)) Q:$E(A,1,2)'="OV" S B="" F S B=$O(DPP(DIBT3,A,B)) Q:B="" S C=$G(DPP(DIBT3,A,B)) I C]"" S D=D+1,%=3,%(1)=19,X=A,DINUM=D D DICM I Y>0 S $P(^DIBT(DIBT1,2,DIBT2,3,+Y,0),U,2)=B,^("OVF0")=C
.Q
I $D(DIBTOLD) K DIBTOLD D K Q
S DIBT2=+$G(DPP(0))
S0 S DIBT2=DIBT2+1 G N:DIBT2>DPP,S0:'$D(DPP(DIBT2,"F")),S0:$P(DPP(DIBT2),U,4)["B"
S DIR("?",1)="Answer YES if you want the to allow the user to specify beginning and",DIR("?")="ending sort values when the print job is run."
W ! S DIR("A")="SHOULD TEMPLATE USER BE ASKED 'FROM'-'TO' RANGE FOR '"_$P(DPP(DIBT2),U,3)_"'",DIR("B")="NO",DIR(0)="Y" D ^DIR K DIR I $D(DIRUT) D K G Q^DIP
G:Y=0 S0
S1 S ^DIBT(DIBT1,2,DIBT2,"ASK")=1
G S0
;
DICM S DIC="^DIBT("_DIBT1_",2,"_DIBT2_","_%_",",DA(2)=DIBT1,DA(1)=DIBT2,DIC(0)="L",DIOVRD=1,DIC("P")=$P(^DD(.4014,%(1),0),U,2)
N C,D
I %(1)=18 S DIC("DR")="1////"_B F C=1,2,3 S D=$P(DPP(DIBT3,A,B),U,C) I D]"" S DIC("DR")=DIC("DR")_";"_(C+1)_"////"_D
N A,B,DD,DO D FILE^DICN K DIC,DA,DINUM,DIOVRD Q
;
US S $P(^DIBT(DIBT1,0),U,7)=DT I '$O(^DIBT(+$G(DIBT1),2,0)) Q
N % F X=+$G(DPP(0)):0 S X=$O(DPP(X)) Q:'X D
. F %="F","T","SER","TXT","IX","PTRIX","QCON","SRTTXT","FCOMPUTED","TCOMPUTED" K ^DIBT(DIBT1,2,X,%) I $G(DPP(X,%))]"" M:%'="SER" ^DIBT(DIBT1,2,X,%)=DPP(X,%)
. Q
Q
;
K K DIEDT,DIBT2,DIBT3 Q
N D K G N^DIP1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIBT 5100 printed Apr 09, 2024@21:49:34 Page 2
DIBT ;SFISC/GFT,TKW,TOAD-STORE A SORT TEMPLATE ;8SEP2014
+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 ;
0 ; select and edit templates, until user quits
+1 SET DIC="^DOPT(""DIBT"","
SET DICF=DI
+2 IF '$DATA(^DOPT("DIBT",.402))
SET ^(0)="TEMPLATE FILE^1.01"
KILL ^("B")
Begin DoDot:1
+3 FOR X=.4,.401,.402
SET ^DOPT("DIBT",X,0)=$PIECE(^DIC(X,0),U)
+4 NEW DIK
SET DIK=DIC
DO IXALL^DIK
End DoDot:1
+5 SET DIC(0)="QEAIN"
SET DIC("A")="Select TEMPLATE File: "
+6 SET DIC("S")="I Y=.4!(Y=.401)!(Y=.402)"
+7 DO ^DIC
KILL DIC
if Y<0
QUIT
+8 KILL DTOUT
FOR
if '$$T(+Y,DICF)
QUIT
IF $DATA(DTOUT)
KILL DTOUT
QUIT
+9 QUIT
+10 ;
T(DDSFILE,DICF) ;=.4,.401,.402
+1 NEW Y,DIC,DIERR,DDSPARM,DR,DA,DIN
+2 WRITE !!
SET DIC=DDSFILE
SET DIC("S")="I $P(^(0),U,4)="_DICF_",Y'<1"
SET D="F"_DICF
+3 SET DIC(0)="AEQI"
DO IX^DIC
IF Y<0
QUIT 0
+4 SET DA=+Y
SET DIN=$$SCREEN
if DIN=0
GOTO SCROLL
IF 'DIN
QUIT 0
+5 SET DIN=$SELECT(DDSFILE=.4:"DIPTED",DDSFILE=.402:"DIETED",1:"DIBTED")
+6 SET DR="["_DIN_"]"
SET DDSPARM=""
DO ^DDS
QUIT '$DATA(DIERR)
+7 ;
SCROLL NEW DIE,DIOVRD,DR
+1 ;TRICK: NOT EVERY ONE OF THE 3 TEMPLATE FILES HAS ALL THESE FIELDS
SET DIE=DDSFILE
SET DR=".01:3;5:7;10;21409;707;491620"
SET DIOVRD=1
DO ^DIE
QUIT 1
+2 ;
SCREEN(HELP) ;
+1 NEW DIR,DIRUT,DUOUT,X,Y,DIERR
+2 ;COMMENT OUT THIS LINE IF YOU WANT FILEMAN TO REMEMBER!
KILL DUZ("SCREEN")
+3 IF $GET(DUZ("SCREEN"))=0
QUIT 0
+4 DO SET^DDGLIB0
IF $DATA(DIERR)
QUIT 0
+5 ;ABORT
IF '$GET(DUZ("SCREEN"))
Begin DoDot:1
+6 SET DIR(0)="Y"
SET DIR("A")="Do you want to use the screen-mode version"
SET DIR("B")="YES"
+7 IF $DATA(HELP)
SET DIR("?")=HELP
+8 DO ^DIR
IF Y-1
if Y=0
SET DUZ("SCREEN")=0
QUIT
+9 SET DUZ("SCREEN")=1
End DoDot:1
IF '$DATA(DUZ("SCREEN"))
QUIT U
+10 DO KILL^DDGLIB0()
+11 ;I ^DD("OS")=9 U $I:VT=1 ;FOR DATATREE
+12 QUIT +$GET(DUZ("SCREEN"))
+13 ;
+14 ;
+15 ;
S ;
+1 DO S1^DIBT1
KILL DIRUT,DIROUT
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO Q^DIP
+2 if X=""
GOTO N
if Y<0
GOTO S
+3 SET DIBT1=+Y
SNEW ;COME HERE FROM DIP1
+1 KILL ^DIBT(DIBT1,2),^("BY0"),^("BY0D")
SET $PIECE(^DIBT(DIBT1,0),U,7)=DT
+2 IF $GET(BY(0))]""
IF $DATA(DPP(0))
Begin DoDot:1
+3 NEW DIBY,DIREC,%,I,D,F,T,Q1,Q2,O
SET %=DIBT1_","
SET DIBY(.401,%,1622)=$PIECE(BY(0),U,2)
SET DIBY(.401,%,1623)=DPP(0)+1
DO FILE^DIE("E","DIBY")
+4 FOR I=1:1:DPP(0)
Begin DoDot:2
+5 SET F=$PIECE($GET(DPP(I,"F")),U,2)
SET T=$PIECE($GET(DPP(I,"T")),U,2)
SET O=$PIECE($GET(DPP(I)),U,4)
SET Q1=""
if O["!"
SET Q1=Q1_"!"
if O["#"
SET Q1=Q1_"#"
SET Q2=$PIECE($GET(DPP(I)),U,5)
SET O=$GET(DPP(I,"OUT"))
+6 SET %="+"_I_","_DIBT1_","
KILL DIBY(.4011624,%)
+7 if F]""
SET DIBY(.4011624,%,1)=F
if T]""
SET DIBY(.4011624,%,2)=T
if Q1]""
SET DIBY(.4011624,%,3.1)=Q1
if Q2]""
SET DIBY(.4011624,%,3.2)=Q2
if O]""
SET DIBY(.4011624,%,4)=O
+8 if '$DATA(DIBY(.4011624,%))
QUIT
SET DIBY(.4011624,%,.01)=I
SET DIREC(I)=I
QUIT
End DoDot:2
+9 DO UPDATE^DIE("E","DIBY","DIREC")
+10 QUIT
End DoDot:1
+11 ;LOOP THRU THE SORT LEVELS
SET (DIBT2,DIBT3)=+$GET(DPP(0))
FOR
SET DIBT3=$ORDER(DPP(DIBT3))
if 'DIBT3
QUIT
SET DIBT2=DIBT2+1
Begin DoDot:1
+12 NEW DIC,DA,DIE,DINUM,DIOVRD,DR,DO
SET X=$PIECE(DPP(DIBT3),U)
if +$PIECE(X,"E")'=X
QUIT
SET DIC="^DIBT("_DIBT1_",2,"
SET DIC(0)="L"
SET DA(1)=DIBT1
SET DINUM=DIBT2
SET DIOVRD=1
SET DIC("P")=$PIECE(^DD(.401,1621,0),U,2)
DO FILE^DICN
KILL DIC,DA,DINUM,DIOVRD
+13 NEW A,B,C,D
SET $PIECE(^DIBT(DIBT1,2,DIBT2,0),U,2,10)=$PIECE(DPP(DIBT3),U,2,10)
EGP ;**CCO/NI PUT THE CORRECT NAME INTO STORED TEMPLATE
IF $DATA(DPP(DIBT3,"LANG"))=11
SET $PIECE(^(0),U,3)=DPP(DIBT3,"LANG")
+1 SET A="A"
FOR
SET A=$ORDER(DPP(DIBT3,A))
if A=""
QUIT
Begin DoDot:2
+2 ;SAVE STUFF FROM DPP, BUT DON'T SAVE FURRIN-LANGUAGE 'TEXT'
SET %=$GET(DPP(DIBT3,A))
IF %]""
IF (A'="TXT")!($GET(DUZ("LANG"))'>1)
Begin DoDot:3
+3 SET ^DIBT(DIBT1,2,DIBT2,A)=%
+4 IF A["COMPUTED"
MERGE ^DIBT(DIBT1,2,DIBT2,A)=DPP(DIBT3,A)
End DoDot:3
End DoDot:2
+5 SET (C,D)=0
FOR A=-1:0
SET A=$ORDER(DPP(DIBT3,A))
if +$PIECE(A,"E")'=A
QUIT
Begin DoDot:2
+6 IF $GET(DPP(DIBT3,A))]""
SET C=C+1
SET %=1
SET %(1)=17
SET X=A
SET DINUM=C
SET DIC("DR")="1////"_DPP(DIBT3,A)
DO DICM
+7 SET B=""
FOR
SET B=$ORDER(DPP(DIBT3,A,B))
if B=""
QUIT
SET D=D+1
SET %=2
SET %(1)=18
SET X=A
SET DINUM=D
DO DICM
if Y>0
SET ^DIBT(DIBT1,2,DIBT2,2,+Y,"RCOD")=$PIECE(DPP(DIBT3,A,B),U,4,99)
+8 QUIT
End DoDot:2
+9 SET D=0
SET A="OV"
FOR
SET A=$ORDER(DPP(DIBT3,A))
if $EXTRACT(A,1,2)'="OV"
QUIT
SET B=""
FOR
SET B=$ORDER(DPP(DIBT3,A,B))
if B=""
QUIT
SET C=$GET(DPP(DIBT3,A,B))
IF C]""
SET D=D+1
SET %=3
SET %(1)=19
SET X=A
SET DINUM=D
DO DICM
IF Y>0
SET $PIECE(^DIBT(DIBT1,2,DIBT2,3,+Y,0),U,2)=B
SET ^("OVF0")=C
+10 QUIT
End DoDot:1
+11 IF $DATA(DIBTOLD)
KILL DIBTOLD
DO K
QUIT
+12 SET DIBT2=+$GET(DPP(0))
S0 SET DIBT2=DIBT2+1
if DIBT2>DPP
GOTO N
if '$DATA(DPP(DIBT2,"F"))
GOTO S0
if $PIECE(DPP(DIBT2),U,4)["B"
GOTO S0
+1 SET DIR("?",1)="Answer YES if you want the to allow the user to specify beginning and"
SET DIR("?")="ending sort values when the print job is run."
+2 WRITE !
SET DIR("A")="SHOULD TEMPLATE USER BE ASKED 'FROM'-'TO' RANGE FOR '"_$PIECE(DPP(DIBT2),U,3)_"'"
SET DIR("B")="NO"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO K
GOTO Q^DIP
+3 if Y=0
GOTO S0
S1 SET ^DIBT(DIBT1,2,DIBT2,"ASK")=1
+1 GOTO S0
+2 ;
DICM SET DIC="^DIBT("_DIBT1_",2,"_DIBT2_","_%_","
SET DA(2)=DIBT1
SET DA(1)=DIBT2
SET DIC(0)="L"
SET DIOVRD=1
SET DIC("P")=$PIECE(^DD(.4014,%(1),0),U,2)
+1 NEW C,D
+2 IF %(1)=18
SET DIC("DR")="1////"_B
FOR C=1,2,3
SET D=$PIECE(DPP(DIBT3,A,B),U,C)
IF D]""
SET DIC("DR")=DIC("DR")_";"_(C+1)_"////"_D
+3 NEW A,B,DD,DO
DO FILE^DICN
KILL DIC,DA,DINUM,DIOVRD
QUIT
+4 ;
US SET $PIECE(^DIBT(DIBT1,0),U,7)=DT
IF '$ORDER(^DIBT(+$GET(DIBT1),2,0))
QUIT
+1 NEW %
FOR X=+$GET(DPP(0)):0
SET X=$ORDER(DPP(X))
if 'X
QUIT
Begin DoDot:1
+2 FOR %="F","T","SER","TXT","IX","PTRIX","QCON","SRTTXT","FCOMPUTED","TCOMPUTED"
KILL ^DIBT(DIBT1,2,X,%)
IF $GET(DPP(X,%))]""
if %'="SER"
MERGE ^DIBT(DIBT1,2,X,%)=DPP(X,%)
+3 QUIT
End DoDot:1
+4 QUIT
+5 ;
K KILL DIEDT,DIBT2,DIBT3
QUIT
N DO K
GOTO N^DIP1
