- DIBT ;SFISC/GFT,TKW,TOAD-STORE A SORT TEMPLATE ;11NOV2008
- ;;22.0;VA FileMan;**82,160**;Mar 30, 1999;Build 23
- ;Per VHA Directive 2004-038, this routine should not be modified.
- 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;707;491620",DIOVRD=1 D ^DIE Q 1
- ;
- 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 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
- .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)
- .S A="A" F S A=$O(DPP(DIBT3,A)) Q:A="" S %=$G(DPP(DIBT3,A)) S:%]"" ^DIBT(DIBT1,2,DIBT2,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" K ^DIBT(DIBT1,2,X,%) I $G(DPP(X,%))]"" S:%'="SER" ^DIBT(DIBT1,2,X,%)=DPP(X,%)
- . Q
- Q
- ;
- K K DIEDT,DIBT2,DIBT3 Q
- N D K G N^DIP1
- DIBT ;SFISC/GFT,TKW,TOAD-STORE A SORT TEMPLATE ;11NOV2008
- +1 ;;22.0;VA FileMan;**82,160**;Mar 30, 1999;Build 23
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- 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 SET DIE=DDSFILE
- SET DR=".01:3;5:7;10;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 ;
- 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 KILL ^DIBT(DIBT1,2),^("BY0"),^("BY0D")
- SET $PIECE(^DIBT(DIBT1,0),U,7)=DT
- +1 IF $GET(BY(0))]""
- IF $DATA(DPP(0))
- Begin DoDot:1
- +2 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")
- +3 FOR I=1:1:DPP(0)
- Begin DoDot:2
- +4 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"))
- +5 SET %="+"_I_","_DIBT1_","
- KILL DIBY(.4011624,%)
- +6 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
- +7 IF '$DATA(DIBY(.4011624,%))
- QUIT
- SET DIBY(.4011624,%,.01)=I
- SET DIREC(I)=I
- QUIT
- End DoDot:2
- +8 DO UPDATE^DIE("E","DIBY","DIREC")
- +9 QUIT
- End DoDot:1
- +10 SET (DIBT2,DIBT3)=+$GET(DPP(0))
- FOR
- SET DIBT3=$ORDER(DPP(DIBT3))
- IF 'DIBT3
- QUIT
- SET DIBT2=DIBT2+1
- Begin DoDot:1
- +11 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
- +12 NEW A,B,C,D
- SET $PIECE(^DIBT(DIBT1,2,DIBT2,0),U,2,10)=$PIECE(DPP(DIBT3),U,2,10)
- +13 SET A="A"
- FOR
- SET A=$ORDER(DPP(DIBT3,A))
- IF A=""
- QUIT
- SET %=$GET(DPP(DIBT3,A))
- IF %]""
- SET ^DIBT(DIBT1,2,DIBT2,A)=%
- +14 SET (C,D)=0
- FOR A=-1:0
- SET A=$ORDER(DPP(DIBT3,A))
- IF +$PIECE(A,"E")'=A
- QUIT
- Begin DoDot:2
- +15 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
- +16 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)
- +17 QUIT
- End DoDot:2
- +18 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
- +19 QUIT
- End DoDot:1
- +20 IF $DATA(DIBTOLD)
- KILL DIBTOLD
- DO K
- QUIT
- +21 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"
- KILL ^DIBT(DIBT1,2,X,%)
- IF $GET(DPP(X,%))]""
- IF %'="SER"
- SET ^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
