DIO0 ;SFISC/GFT,TKW - BUILD SORT AND SUB-HDR ;01MAR2016
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;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.
;
S Z=Z+1,DE=$P(DN,",",Z)_"=$O("_DI_$P(DN,",",1,Z)_")),DN="_(Z+1)
I Z=1,$G(DPP(DJK,"PTRIX"))]"" D
DIOO1 . S DE="DIOO1=$O("_DPP(DJK,"PTRIX")_"DIOO1)),DN=1.5,DD00=0"
. S DY(1.5)="S DD00=$O("_DPP(DJK,"PTRIX")_"DIOO1,DD00)),DN=2 S:'DD00 DN=1"
. I DPP(DJK,"PTRIX")?.E1"""B""," S DY(1.5)=DY(1.5)_" S:DD00&($G(^(+DD00))!('($D(^(+DD00))=1))) DN=1"
. Q
I DPQ,Z=1,$D(DPP(DJK,"IX")),$O(DPP(DJK,0)) D
.S DXIX=$P(DPP(DJK),U) Q:'DXIX S DXIX(DXIX)=U_$P(DPP(DJK,"IX"),U,2)_$S($D(DPP(DJK,"PTRIX")):"DD00,D0",1:DN)
.S W=0,%(1)="" F %=0:0 S W=$O(DPP(DJK,W)) Q:'W S %=%+1,%(1)=%(1)_",D"_%
.S DXIX(DXIX)=DXIX(DXIX)_%(1)
.K %,W Q
I Z<$G(DPP(0)) S Y=$P($G(DPP(Z+1,"F")),U) I Y]""!($G(DPP(Z+1,"T"))]"") S:+$P(Y,"E")'=Y Y=""""_Y_"""" S DE=DE_","_$P(DN,",",Z+1)_"="_Y
I 'DPQ,$D(DPP(Z)) D H
I DPQ,Z=DD S DE=DE_" S:D0 DISTP=DISTP+1 D:'(DISTP#100) CSTP"_$P("^DIO2",1,$D(DIBTPGM))_" Q:'DN "
S X=DE_" I "_$P(DN,",",Z)_$S(DD=Z:"'>0",1:"=""""")
S Y="" D
.I Z=1,$D(DPP(DJK,"T")),$D(DPP(DJK,"IX")) S Y=$P(DPP(DJK,"T"),U)
.I $G(DPP(0)),Z<(DPP(0)+1) S Y=$P($G(DPP(Z,"T")),U)
.I Y]"",Y'="@",Y'="z" S X=X_"!("_$$AFT^DIOC($P(DN,",",Z),Y)_")"
.Q
D0 S X=X_" S DN="_$S(Z=DD&($D(DPP(DJK,"PTRIX"))):1.5,1:(Z-1)),Y=Z-1 I Z=1 S X=X_",D0=-1" I $D(DPP(DJK,"PTRIX")) S X=X_" K DD00",$P(DN,",")="DD00"
I 'DPQ,$D(DPP(Y)) S:$P(DPP(Y),U,4)["!" X="DRK=DRK+1,"_X_",DRK=0",DRK=0 D SUB
S DY(Z)="S "_X
I $D(DIBTPGM) D
. S DY(Z)=$S(Z'=1:"DY"_Z,1:"EN")_" Q:'DN "_DY(Z)_$S(Z=1:" Q",Z=2&($D(DPP(DJK,"PTRIX"))):" G DYP",Z=2:" G EN",1:" G DY"_(Z-1))
. I $D(DPP(DJK,"PTRIX")),Z=1 S DY(1.5)="DYP Q:'DN "_DY(1.5)_" G:DN=1 EN"
. Q
G DIO0:Z<DD ;THIS IS A LOOP
;
F %=1:1 Q:'$D(DPP(%)) K DPP(%,"PTRIX")
S %=$S($G(DIO("SCR"))=1:"O",$D(DIS)<9:"O",$D(DIS)=11:"SCR",1:"SEARCH")
S DY(Z+1)="S DN="_Z_" " I DJ["""B"",^" S DY(Z+1)=DY(Z+1)_"I $D("_DI_$P(DN,",",1,Z)_"))'[0,'^(D0) "
S DY(Z+1)=DY(Z+1)_"D "_%,Y=Z,X=""
I 'DPQ,$D(DPP(Y)),$P(DPP(Y),U,2)=0 D SUB I S DY(Z+1)=DY(Z+1)_" S "_$E(X,2,99)
I A=1 D:$D(DIBTPGM) SETU Q
S X="," F W=1:1:A-1 S ^DOSV(0,IO(0),"BY",W)=DPP(A(W)),X=X_$P(DN,",",A(W))_",",A(W)="Q"
S A(W)="S ^DOSV(0,IO(0),"_W_X_"V,DE)=Y"
HD I $G(DIOSTAHD),$G(^UTILITY($J,2))?1"W ".E S ^DOSV(0,IO(0),"HD")=^(2)
F W=1:1:DPP S X=$$CONVQ^DILIBF($G(DPP(W,"TXT"))) I X]"",$P(DPP(W),U,4)'["+" D S:X]"" ^("SHD")=$S($D(^DOSV(0,IO(0),"SHD")):^("SHD")_" BY ",1:"")_X
.N F,C S C=$F($P(DPP(W),U,5),";""")
.I C S Y=$P(DPP(W),U,3),F=$F(X,Y) I Y]"",F S C=$E(X,0,F-$L(Y)-1)_$P($E($P(DPP(W),U,5),C,99),"""") S X=$S(C]"":C_$E(X,F,999),1:"")
D:$D(DIBTPGM) SETU Q
;
SUB I $P($G(DPP(Y)),U,4)["+" S A(A)=Y,X=X_",A="_A_" D"_$S($D(DIS)<9:"",1:":$D(DIPASS)")_" ^DIO3"_$S($D(DIS)<9:"",1:" K DIPASS"),A=A+1
Q
;
H S DOP=0 I $D(DNP) F W=1:1 G Q:'$D(DPP(W)) I DPP(W)["+" K DNP S DOP=1 Q
S Y=$P(DN,",",Z),F=$P(DPP(Z),U,5),W=$P(DPP(Z),U,4),X=$P(W,"""",2),V=+$P(DPP(Z),U,2) S:W["-" Y="(-"_Y_")"
I F'[""""&'$D(DPQ(+DPP(Z),V+X))&'DOP!(W["@")!(W["'")!$D(DISH) S (Y,V)="" G F:F]"",U
I F[";TXT" S Y="$E("_Y_",2,$L("_Y_"))"
EGP I '$D(^DD(+DPP(Z),V,0)) S X=$P(DPP(Z),U,6,9)
E D
.N N,T
.S X=^DD(+DPP(Z),V,0),N=$P(X,U)
.S T=$$LABEL^DIALOGZ(+DPP(Z),V),$P(X,U)=T
.I N=$P(DPP(Z),U,3) S $P(DPP(Z),U,3)=T
DT I $P(X,U,2)["D" S Y=" S Y="_Y_" D:Y<9999999 DT"
E I $G(DPP(Z,"OUT"))]"" S DPP(Z,"OUT")=" S Y="_Y_" "_DPP(Z,"OUT"),Y=",Y" ;THIS WILL HANDLE 'TRANSFORM FOR SORT' FIELDS THAT NEED REVERSE-TRANSFORM!
E I $P(X,U,2)["O"!($P(X,U,4)?.P)!($P(X,U,2)["t"&($P(X,U,2)'["S")) S Y=","_Y ;IF IT HAS BEEN OUTPUT-TRANSFORMED, OR IF IT IS COMPUTED, IT IS ALREADY DISPLAYABLE
DILL E D EN^DILL(+DPP(Z),V,1) ;CREATES A WRITE STATEMENT IN 'Y' VARIABLE
S V=$P(F,";C",2),V="?"_$S(V:V-1,1:Z*3+5)
F I F[";S" S %=$P(F,";S",2) S:'% %=1 S V=$E("!!!!!!!!!!!!!!!!!!!!!!!!!!!!",1,%)_V,M=M+% ;SKIP a number of lines of output
S F=$P(F,";""",2),%=$S(W["@":"",W["'":"",F]"":$P(F,"""",1,$L(F,"""")-1),Y]"":$P($P(DPP(Z),U,3),"""",1)_": ",1:"") ;CAPTION OF SUBHEADER
S Y=V_$S(%_Y]"":$E(",",V]"")_""""_%_"""",1:"")_Y
I Y]"" S Y=" I DN D T"_$G(DPP(Z,"OUT"))_" W "_Y ;STOP IF THEY TYPE "^"
U S W=W'["#" I W,Y="",$D(DPP(Z+1)) G E
S ^UTILITY($J,"H",Z)="X ^UTILITY($J,1)"_$P(":$Y>"_(DIOSL-M-2-DD+Z)_"!(DC["","")",U,W)_Y,Y="D H:DI<DN ",DE=DE_$S(Z=1:",DI=0",1:" S:DI>"_Z_" DI="_Z)
S:^UTILITY($J,99,0)'[Y ^(0)=Y_^(0)
E I DOP S DNP=""
Q K DOP Q
;
SETU ;PUT DY ARRAY INTO ^UTILITY FOR LATER COMPILATION
N DN
F DN=0:0 S DN=$O(DY(DN)) Q:'DN D
.S ^TMP("DIBTC",$J,0,DICNT)=$E(" ",'$O(DY(DN)))_DY(DN),DICNT=DICNT+1
.I '$O(DY(DN)) S ^TMP("DIBTC",$J,0,DICNT)=$S(DN>2:" G DY"_(DN-1),1:" G EN"),DICNT=DICNT+1
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIO0 4971 printed Apr 09, 2024@21:55:37 Page 2
DIO0 ;SFISC/GFT,TKW - BUILD SORT AND SUB-HDR ;01MAR2016
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+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 ;
+7 SET Z=Z+1
SET DE=$PIECE(DN,",",Z)_"=$O("_DI_$PIECE(DN,",",1,Z)_")),DN="_(Z+1)
+8 IF Z=1
IF $GET(DPP(DJK,"PTRIX"))]""
Begin DoDot:1
DIOO1 SET DE="DIOO1=$O("_DPP(DJK,"PTRIX")_"DIOO1)),DN=1.5,DD00=0"
+1 SET DY(1.5)="S DD00=$O("_DPP(DJK,"PTRIX")_"DIOO1,DD00)),DN=2 S:'DD00 DN=1"
+2 IF DPP(DJK,"PTRIX")?.E1"""B"","
SET DY(1.5)=DY(1.5)_" S:DD00&($G(^(+DD00))!('($D(^(+DD00))=1))) DN=1"
+3 QUIT
End DoDot:1
+4 IF DPQ
IF Z=1
IF $DATA(DPP(DJK,"IX"))
IF $ORDER(DPP(DJK,0))
Begin DoDot:1
+5 SET DXIX=$PIECE(DPP(DJK),U)
if 'DXIX
QUIT
SET DXIX(DXIX)=U_$PIECE(DPP(DJK,"IX"),U,2)_$SELECT($DATA(DPP(DJK,"PTRIX")):"DD00,D0",1:DN)
+6 SET W=0
SET %(1)=""
FOR %=0:0
SET W=$ORDER(DPP(DJK,W))
if 'W
QUIT
SET %=%+1
SET %(1)=%(1)_",D"_%
+7 SET DXIX(DXIX)=DXIX(DXIX)_%(1)
+8 KILL %,W
QUIT
End DoDot:1
+9 IF Z<$GET(DPP(0))
SET Y=$PIECE($GET(DPP(Z+1,"F")),U)
IF Y]""!($GET(DPP(Z+1,"T"))]"")
if +$PIECE(Y,"E")'=Y
SET Y=""""_Y_""""
SET DE=DE_","_$PIECE(DN,",",Z+1)_"="_Y
+10 IF 'DPQ
IF $DATA(DPP(Z))
DO H
+11 IF DPQ
IF Z=DD
SET DE=DE_" S:D0 DISTP=DISTP+1 D:'(DISTP#100) CSTP"_$PIECE("^DIO2",1,$DATA(DIBTPGM))_" Q:'DN "
+12 SET X=DE_" I "_$PIECE(DN,",",Z)_$SELECT(DD=Z:"'>0",1:"=""""")
+13 SET Y=""
Begin DoDot:1
+14 IF Z=1
IF $DATA(DPP(DJK,"T"))
IF $DATA(DPP(DJK,"IX"))
SET Y=$PIECE(DPP(DJK,"T"),U)
+15 IF $GET(DPP(0))
IF Z<(DPP(0)+1)
SET Y=$PIECE($GET(DPP(Z,"T")),U)
+16 IF Y]""
IF Y'="@"
IF Y'="z"
SET X=X_"!("_$$AFT^DIOC($PIECE(DN,",",Z),Y)_")"
+17 QUIT
End DoDot:1
D0 SET X=X_" S DN="_$SELECT(Z=DD&($DATA(DPP(DJK,"PTRIX"))):1.5,1:(Z-1))
SET Y=Z-1
IF Z=1
SET X=X_",D0=-1"
IF $DATA(DPP(DJK,"PTRIX"))
SET X=X_" K DD00"
SET $PIECE(DN,",")="DD00"
+1 IF 'DPQ
IF $DATA(DPP(Y))
if $PIECE(DPP(Y),U,4)["!"
SET X="DRK=DRK+1,"_X_",DRK=0"
SET DRK=0
DO SUB
+2 SET DY(Z)="S "_X
+3 IF $DATA(DIBTPGM)
Begin DoDot:1
+4 SET DY(Z)=$SELECT(Z'=1:"DY"_Z,1:"EN")_" Q:'DN "_DY(Z)_$SELECT(Z=1:" Q",Z=2&($DATA(DPP(DJK,"PTRIX"))):" G DYP",Z=2:" G EN",1:" G DY"_(Z-1))
+5 IF $DATA(DPP(DJK,"PTRIX"))
IF Z=1
SET DY(1.5)="DYP Q:'DN "_DY(1.5)_" G:DN=1 EN"
+6 QUIT
End DoDot:1
+7 ;THIS IS A LOOP
if Z<DD
GOTO DIO0
+8 ;
+9 FOR %=1:1
if '$DATA(DPP(%))
QUIT
KILL DPP(%,"PTRIX")
+10 SET %=$SELECT($GET(DIO("SCR"))=1:"O",$DATA(DIS)<9:"O",$DATA(DIS)=11:"SCR",1:"SEARCH")
+11 SET DY(Z+1)="S DN="_Z_" "
IF DJ["""B"",^"
SET DY(Z+1)=DY(Z+1)_"I $D("_DI_$PIECE(DN,",",1,Z)_"))'[0,'^(D0) "
+12 SET DY(Z+1)=DY(Z+1)_"D "_%
SET Y=Z
SET X=""
+13 IF 'DPQ
IF $DATA(DPP(Y))
IF $PIECE(DPP(Y),U,2)=0
DO SUB
IF $TEST
SET DY(Z+1)=DY(Z+1)_" S "_$EXTRACT(X,2,99)
+14 IF A=1
if $DATA(DIBTPGM)
DO SETU
QUIT
+15 SET X=","
FOR W=1:1:A-1
SET ^DOSV(0,IO(0),"BY",W)=DPP(A(W))
SET X=X_$PIECE(DN,",",A(W))_","
SET A(W)="Q"
+16 SET A(W)="S ^DOSV(0,IO(0),"_W_X_"V,DE)=Y"
HD IF $GET(DIOSTAHD)
IF $GET(^UTILITY($JOB,2))?1"W ".E
SET ^DOSV(0,IO(0),"HD")=^(2)
+1 FOR W=1:1:DPP
SET X=$$CONVQ^DILIBF($GET(DPP(W,"TXT")))
IF X]""
IF $PIECE(DPP(W),U,4)'["+"
Begin DoDot:1
+2 NEW F,C
SET C=$FIND($PIECE(DPP(W),U,5),";""")
+3 IF C
SET Y=$PIECE(DPP(W),U,3)
SET F=$FIND(X,Y)
IF Y]""
IF F
SET C=$EXTRACT(X,0,F-$LENGTH(Y)-1)_$PIECE($EXTRACT($PIECE(DPP(W),U,5),C,99),"""")
SET X=$SELECT(C]"":C_$EXTRACT(X,F,999),1:"")
End DoDot:1
if X]""
SET ^("SHD")=$SELECT($DATA(^DOSV(0,IO(0),"SHD")):^("SHD")_" BY ",1:"")_X
+4 if $DATA(DIBTPGM)
DO SETU
QUIT
+5 ;
SUB IF $PIECE($GET(DPP(Y)),U,4)["+"
SET A(A)=Y
SET X=X_",A="_A_" D"_$SELECT($DATA(DIS)<9:"",1:":$D(DIPASS)")_" ^DIO3"_$SELECT($DATA(DIS)<9:"",1:" K DIPASS")
SET A=A+1
+1 QUIT
+2 ;
H SET DOP=0
IF $DATA(DNP)
FOR W=1:1
if '$DATA(DPP(W))
GOTO Q
IF DPP(W)["+"
KILL DNP
SET DOP=1
QUIT
+1 SET Y=$PIECE(DN,",",Z)
SET F=$PIECE(DPP(Z),U,5)
SET W=$PIECE(DPP(Z),U,4)
SET X=$PIECE(W,"""",2)
SET V=+$PIECE(DPP(Z),U,2)
if W["-"
SET Y="(-"_Y_")"
+2 IF F'[""""&'$DATA(DPQ(+DPP(Z),V+X))&'DOP!(W["@")!(W["'")!$DATA(DISH)
SET (Y,V)=""
if F]""
GOTO F
GOTO U
+3 IF F[";TXT"
SET Y="$E("_Y_",2,$L("_Y_"))"
EGP IF '$DATA(^DD(+DPP(Z),V,0))
SET X=$PIECE(DPP(Z),U,6,9)
+1 IF '$TEST
Begin DoDot:1
+2 NEW N,T
+3 SET X=^DD(+DPP(Z),V,0)
SET N=$PIECE(X,U)
+4 SET T=$$LABEL^DIALOGZ(+DPP(Z),V)
SET $PIECE(X,U)=T
+5 IF N=$PIECE(DPP(Z),U,3)
SET $PIECE(DPP(Z),U,3)=T
End DoDot:1
DT IF $PIECE(X,U,2)["D"
SET Y=" S Y="_Y_" D:Y<9999999 DT"
+1 ;THIS WILL HANDLE 'TRANSFORM FOR SORT' FIELDS THAT NEED REVERSE-TRANSFORM!
IF '$TEST
IF $GET(DPP(Z,"OUT"))]""
SET DPP(Z,"OUT")=" S Y="_Y_" "_DPP(Z,"OUT")
SET Y=",Y"
+2 ;IF IT HAS BEEN OUTPUT-TRANSFORMED, OR IF IT IS COMPUTED, IT IS ALREADY DISPLAYABLE
IF '$TEST
IF $PIECE(X,U,2)["O"!($PIECE(X,U,4)?.P)!($PIECE(X,U,2)["t"&($PIECE(X,U,2)'["S"))
SET Y=","_Y
DILL ;CREATES A WRITE STATEMENT IN 'Y' VARIABLE
IF '$TEST
DO EN^DILL(+DPP(Z),V,1)
+1 SET V=$PIECE(F,";C",2)
SET V="?"_$SELECT(V:V-1,1:Z*3+5)
F ;SKIP a number of lines of output
IF F[";S"
SET %=$PIECE(F,";S",2)
if '%
SET %=1
SET V=$EXTRACT("!!!!!!!!!!!!!!!!!!!!!!!!!!!!",1,%)_V
SET M=M+%
+1 ;CAPTION OF SUBHEADER
SET F=$PIECE(F,";""",2)
SET %=$SELECT(W["@":"",W["'":"",F]"":$PIECE(F,"""",1,$LENGTH(F,"""")-1),Y]"":$PIECE($PIECE(DPP(Z),U,3),"""",1)_": ",1:"")
+2 SET Y=V_$SELECT(%_Y]"":$EXTRACT(",",V]"")_""""_%_"""",1:"")_Y
+3 ;STOP IF THEY TYPE "^"
IF Y]""
SET Y=" I DN D T"_$GET(DPP(Z,"OUT"))_" W "_Y
U SET W=W'["#"
IF W
IF Y=""
IF $DATA(DPP(Z+1))
GOTO E
+1 SET ^UTILITY($JOB,"H",Z)="X ^UTILITY($J,1)"_$PIECE(":$Y>"_(DIOSL-M-2-DD+Z)_"!(DC["","")",U,W)_Y
SET Y="D H:DI<DN "
SET DE=DE_$SELECT(Z=1:",DI=0",1:" S:DI>"_Z_" DI="_Z)
+2 if ^UTILITY($JOB,99,0)'[Y
SET ^(0)=Y_^(0)
E IF DOP
SET DNP=""
Q KILL DOP
QUIT
+1 ;
SETU ;PUT DY ARRAY INTO ^UTILITY FOR LATER COMPILATION
+1 NEW DN
+2 FOR DN=0:0
SET DN=$ORDER(DY(DN))
if 'DN
QUIT
Begin DoDot:1
+3 SET ^TMP("DIBTC",$JOB,0,DICNT)=$EXTRACT(" ",'$ORDER(DY(DN)))_DY(DN)
SET DICNT=DICNT+1
+4 IF '$ORDER(DY(DN))
SET ^TMP("DIBTC",$JOB,0,DICNT)=$SELECT(DN>2:" G DY"_(DN-1),1:" G EN")
SET DICNT=DICNT+1
+5 QUIT
End DoDot:1
+6 QUIT
