- DIO0 ;SFISC/GFT,TKW-BUILD SORT AND SUB-HDR ;28SEP2004
- ;;22.0;VA FileMan;**2,23,138,144**;Mar 30, 1999;Build 5
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- S C=",",Z=Z+1,DE=$P(DN,C,Z)_"=$O("_DI_$P(DN,C,1,Z)_")),DN="_(Z+1) ;22*138
- 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)_C_"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,C,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,C,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,C,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,C,1)="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
- 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,C,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=C F W=1:1:A-1 S ^DOSV(0,IO(0),"BY",W)=DPP(A(W)),X=X_$P(DN,C,A(W))_C,A(W)="Q"
- S A(W)="S ^DOSV(0,IO(0)"_C_W_X_"V,DE)=Y"
- 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_"))"
- S X=$S($D(^DD(+DPP(Z),V,0)):^(0),1:$P(DPP(Z),U,6,9)) I $P(X,U,2)["D" S Y=" S Y="_Y_" D DT"
- E I $G(DPP(Z,"OUT"))]"" S DPP(Z,"OUT")=" S Y="_Y_" "_DPP(Z,"OUT"),Y=",Y"
- E I $P(X,U,2)["O"!($P(X,U,4)?.P) S Y=C_Y
- E D ^DILL
- 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+%
- S F=$P(F,";""",2),%=$S(W["@":"",W["'":"",F]"":$P(F,"""",1,$L(F,"""")-1),Y]"":$P($P(DPP(Z),U,3),"""",1)_": ",1:""),Y=V_$S(%_Y]"":$E(",",V]"")_""""_%_"""",1:"")_Y I Y]"" S Y=" D T"_$G(DPP(Z,"OUT"))_" W "_Y
- 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
- DIO0 ;SFISC/GFT,TKW-BUILD SORT AND SUB-HDR ;28SEP2004
- +1 ;;22.0;VA FileMan;**2,23,138,144**;Mar 30, 1999;Build 5
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;22*138
- SET C=","
- SET Z=Z+1
- SET DE=$PIECE(DN,C,Z)_"=$O("_DI_$PIECE(DN,C,1,Z)_")),DN="_(Z+1)
- +5 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)_C_"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,C,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,C,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,C,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,C,1)="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 IF Z<DD
- GOTO DIO0
- +8 FOR %=1:1
- IF '$DATA(DPP(%))
- QUIT
- KILL DPP(%,"PTRIX")
- +9 SET %=$SELECT($GET(DIO("SCR"))=1:"O",$DATA(DIS)<9:"O",$DATA(DIS)=11:"SCR",1:"SEARCH")
- +10 SET DY(Z+1)="S DN="_Z_" "
- IF DJ["""B"",^"
- SET DY(Z+1)=DY(Z+1)_"I $D("_DI_$PIECE(DN,C,1,Z)_"))'[0,'^(D0) "
- +11 SET DY(Z+1)=DY(Z+1)_"D "_%
- SET Y=Z
- SET X=""
- +12 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)
- +13 IF A=1
- IF $DATA(DIBTPGM)
- DO SETU
- QUIT
- +14 SET X=C
- FOR W=1:1:A-1
- SET ^DOSV(0,IO(0),"BY",W)=DPP(A(W))
- SET X=X_$PIECE(DN,C,A(W))_C
- SET A(W)="Q"
- +15 SET A(W)="S ^DOSV(0,IO(0)"_C_W_X_"V,DE)=Y"
- +16 IF $DATA(DIBTPGM)
- DO SETU
- QUIT
- +17 ;
- 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_")"
- IF F'[""""&'$DATA(DPQ(+DPP(Z),V+X))&'DOP!(W["@")!(W["'")!$DATA(DISH)
- SET (Y,V)=""
- IF F]""
- GOTO F
- GOTO U
- +2 IF F[";TXT"
- SET Y="$E("_Y_",2,$L("_Y_"))"
- +3 SET X=$SELECT($DATA(^DD(+DPP(Z),V,0)):^(0),1:$PIECE(DPP(Z),U,6,9))
- IF $PIECE(X,U,2)["D"
- SET Y=" S Y="_Y_" D DT"
- +4 IF '$TEST
- IF $GET(DPP(Z,"OUT"))]""
- SET DPP(Z,"OUT")=" S Y="_Y_" "_DPP(Z,"OUT")
- SET Y=",Y"
- +5 IF '$TEST
- IF $PIECE(X,U,2)["O"!($PIECE(X,U,4)?.P)
- SET Y=C_Y
- +6 IF '$TEST
- DO ^DILL
- +7 SET V=$PIECE(F,";C",2)
- SET V="?"_$SELECT(V:V-1,1:Z*3+5)
- F IF F[";S"
- SET %=$PIECE(F,";S",2)
- IF '%
- SET %=1
- SET V=$EXTRACT("!!!!!!!!!!!!!!!!!!!!!!!!!!!!",1,%)_V
- SET M=M+%
- +1 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:"")
- SET Y=V_$SELECT(%_Y]"":$EXTRACT(",",V]"")_""""_%_"""",1:"")_Y
- IF Y]""
- SET Y=" 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
