- DIL2 ;SFISC/GFT,XAK,TKW-PROCESS HDRS AND TRAILERS ;9:50 AM 1 Oct 1998
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- D T:$D(^UTILITY($J,"T")) S:DIPT $P(^DIPT(DIPT,0),U,7)=DT S:$D(DIBT) $P(^DIBT(DIBT,0),U,7)=DT S:$G(DISV) $P(^DIBT(DISV,0),U,7)=DT
- F X=0:0 S X=$O(R(X)) Q:X="" I X<500,$O(^UTILITY($J,99,X))>499 S DX=X
- S X=$S($D(DNP):"",$D(DIWR):" D ^DIWW",($G(DIAR)=4!($G(DIAR)=6)):" W "".""",1:" D T")_$S(DIWL:" K DIWF",1:"")_$S($D(CP):" D CP",1:"")_$P(" S DJ=DJ+1",U,$D(DIS)>9&(L!($D(DISTEMP))))_$S($D(DHIT):" X DHIT",1:"")
- I X'["D T" S X=X_" S DISTP=DISTP+1 D:'(DISTP#100) CSTP^DIO2"
- S:$D(DISV) X=X_" S ^DIBT("_DISV_",1,D0)="""""
- S:X]"" DX=DX+1,^UTILITY($J,99,DX)=$E(X,2,999)
- K DIOT S DW=2,(DQI,DV)=DHD,M=M(DP(0)),DL=DV?1"-".E
- I 'DV G HT:DV?.P1"[".E1"]",0:DV?1"W ".E,0:$G(DIFIXPT)=1,0:$G(IOST)?1"C".E S ^UTILITY($J,99,0)="Q" G G
- I $D(DIPZ) S ^UTILITY($J,1)=^UTILITY($J,1)_" X ^UTILITY($J,2) D HEAD"_^DIPT(DIPZ,"ROU")_^("LAST") G 0
- S X="",$P(X,"-",$S(IOM<244:IOM,1:244))="-"
- D O S ^UTILITY($J,DV)="W !,"""_X_""",!!",^(1)=^(1)_O
- 0 S ^UTILITY($J,99,0)="I DC["","""_$S(DIPT=.01:"!($Y>"_(DIOSL-5)_")",1:"")_" X ^UTILITY($J,1)"
- G S DX(0)=^UTILITY($J,99,0) K ^UTILITY($J,0),DXIX
- I $D(DPP(0)) S DJ=DPP(0,"IX"),DPQ=$O(DPP(DPP(0)))]"",DJK=0 G ^DIO
- S DPQ=$P(DPP(1),U,4)["-"!($D(DPP(1,"CM"))&('$D(DPP(1,"PTRIX"))))
- F R=2:1:DPP S:'$D(DPP(R,U)) DPQ=1
- S:$P(DPP(1),U,5)[";L" DPQ=1
- S DJK=1 I DPQ S %=0 F R=1:1:DPP I +$G(DPP(R,"SER"))>% S %=+DPP(R,"SER"),DJK=R
- I $D(DPP(DJK,"IX")) S DJ=DPP(DJK,"IX") G ^DIO
- S DJ=DK_DK_U_1 I $O(DPP(DJK,-1))>0!$P(DPP(DJK),U,2) S DPQ=1
- S:'DPQ DPP(1,"IX")=""
- G ^DIO
- ;
- O S O=" F DE="_DW_":1:"_DHD_" X ^UTILITY($J,DE)" Q
- ;
- T ;
- F DG=-1:0 S DG=$O(^UTILITY($J,"T",DG)) Q:DG="" S Z="""",I=$P(^(DG),U,6,99) I I]"" F W=2:1 Q:$P(I,Z,W,99)="" S V=$P(I,Z,W) I V]"",$D(DCL(V)) S I=$P(I,Z,1,W-1)_+DCL(V)_$P(I,Z,W+1,99),W=W-1,^(DG)=$P(^(DG),U,1,5)_U_I
- Q
- ;
- HT S DLP=DX,DCC=M,DV=DW,DNP(1)=DISMIN D INIT^DIP5 S DISMIN=DNP(1) K DNP(1)
- F %=0:0 S %=$O(^DIPT("B",$P($P(DHD,"[",2),"]",1),%)) G TT:%="" I $D(^DIPT(%,0)),$P(^(0),U,4)=""!($P(^(0),U,4)=DP) S $P(^(0),U,7)=DT Q
- I $D(^("ROU")),^("ROU")[U,'$D(^("DXS")),$D(^("IOM")),^("IOM")'>IOM S ^UTILITY($J,DV)="D "_^("ROU"),DV=DV+1 G EHT
- F V=0:0 S V=$O(^DIPT(%,"DXS",V)) Q:V'>0 F I=0:0 S I=$O(^DIPT(%,"DXS",V,I)) Q:I'>0 S R=^(I) D X S ^UTILITY($J,V,I)=R
- S DX=-1,DHD="^DIPT("_%_",""F"",DHT)" F DHT=0:0 S DHT=$O(@DHD) S:DHT="" DHT=-1 Q:DHT'>0 S R=^(DHT) D X D D UNSTACK^DIL:DM
- . N DNP D ^DIL
- I $L(Y)>1 D PX^DIL
- EHT S DX=DLP,DHD=DV-1,M=M(DP(0)) D O S DW=DV,O=" N X"_O
- I DL S M=M+1,DILIOSL=IOSL-M,^(1)="X DIOT "_^UTILITY($J,1)_" K DIOT(2)",DIOT="I DC?.N,$Y X DIOT(1)"_O,DIOT(1)="S DIOT(2)=1 F %=0:0 W ! Q:$Y>"_DILIOSL_"!($G(DDBRZIS))",M=M+DCC G 0
- S M=DCC,^(1)=^UTILITY($J,1)_O
- TT S DHD=$P(DQI,"]",2) G 0:DHD="" S DL=1 G HT
- ;
- X S W=$F(R,"X DXS("),Y=+$E(R,W,999),X=+$E(R,$F(R,C,W),999) I W,X,Y S R=$E(R,1,W-5)_"^UTILITY($J,"_Y_C_X_$E(R,W+$L(X)+$L(Y)+1,999) G X
- DIL2 ;SFISC/GFT,XAK,TKW-PROCESS HDRS AND TRAILERS ;9:50 AM 1 Oct 1998
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 IF $DATA(^UTILITY($JOB,"T"))
- DO T
- IF DIPT
- SET $PIECE(^DIPT(DIPT,0),U,7)=DT
- IF $DATA(DIBT)
- SET $PIECE(^DIBT(DIBT,0),U,7)=DT
- IF $GET(DISV)
- SET $PIECE(^DIBT(DISV,0),U,7)=DT
- +4 FOR X=0:0
- SET X=$ORDER(R(X))
- IF X=""
- QUIT
- IF X<500
- IF $ORDER(^UTILITY($JOB,99,X))>499
- SET DX=X
- +5 SET X=$SELECT($DATA(DNP):"",$DATA(DIWR):" D ^DIWW",($GET(DIAR)=4!($GET(DIAR)=6)):" W "".""",1:" D T")_$SELECT(DIWL:" K DIWF",1:"")_$SELECT($DATA(CP):" D CP",1:"")_$PIECE(" S DJ=DJ+1",U,$DATA(DIS)>9&(L!($DATA(DISTEMP))))_$SELECT(...
- ... $DATA(DHIT):" X DHIT",1:"")
- +6 IF X'["D T"
- SET X=X_" S DISTP=DISTP+1 D:'(DISTP#100) CSTP^DIO2"
- +7 IF $DATA(DISV)
- SET X=X_" S ^DIBT("_DISV_",1,D0)="""""
- +8 IF X]""
- SET DX=DX+1
- SET ^UTILITY($JOB,99,DX)=$EXTRACT(X,2,999)
- +9 KILL DIOT
- SET DW=2
- SET (DQI,DV)=DHD
- SET M=M(DP(0))
- SET DL=DV?1"-".E
- +10 IF 'DV
- IF DV?.P1"[".E1"]"
- GOTO HT
- IF DV?1"W ".E
- GOTO 0
- IF $GET(DIFIXPT)=1
- GOTO 0
- IF $GET(IOST)?1"C".E
- GOTO 0
- SET ^UTILITY($JOB,99,0)="Q"
- GOTO G
- +11 IF $DATA(DIPZ)
- SET ^UTILITY($JOB,1)=^UTILITY($JOB,1)_" X ^UTILITY($J,2) D HEAD"_^DIPT(DIPZ,"ROU")_^("LAST")
- GOTO 0
- +12 SET X=""
- SET $PIECE(X,"-",$SELECT(IOM<244:IOM,1:244))="-"
- +13 DO O
- SET ^UTILITY($JOB,DV)="W !,"""_X_""",!!"
- SET ^(1)=^(1)_O
- 0 SET ^UTILITY($JOB,99,0)="I DC["","""_$SELECT(DIPT=.01:"!($Y>"_(DIOSL-5)_")",1:"")_" X ^UTILITY($J,1)"
- G SET DX(0)=^UTILITY($JOB,99,0)
- KILL ^UTILITY($JOB,0),DXIX
- +1 IF $DATA(DPP(0))
- SET DJ=DPP(0,"IX")
- SET DPQ=$ORDER(DPP(DPP(0)))]""
- SET DJK=0
- GOTO ^DIO
- +2 SET DPQ=$PIECE(DPP(1),U,4)["-"!($DATA(DPP(1,"CM"))&('$DATA(DPP(1,"PTRIX"))))
- +3 FOR R=2:1:DPP
- IF '$DATA(DPP(R,U))
- SET DPQ=1
- +4 IF $PIECE(DPP(1),U,5)[";L"
- SET DPQ=1
- +5 SET DJK=1
- IF DPQ
- SET %=0
- FOR R=1:1:DPP
- IF +$GET(DPP(R,"SER"))>%
- SET %=+DPP(R,"SER")
- SET DJK=R
- +6 IF $DATA(DPP(DJK,"IX"))
- SET DJ=DPP(DJK,"IX")
- GOTO ^DIO
- +7 SET DJ=DK_DK_U_1
- IF $ORDER(DPP(DJK,-1))>0!$PIECE(DPP(DJK),U,2)
- SET DPQ=1
- +8 IF 'DPQ
- SET DPP(1,"IX")=""
- +9 GOTO ^DIO
- +10 ;
- O SET O=" F DE="_DW_":1:"_DHD_" X ^UTILITY($J,DE)"
- QUIT
- +1 ;
- T ;
- +1 FOR DG=-1:0
- SET DG=$ORDER(^UTILITY($JOB,"T",DG))
- IF DG=""
- QUIT
- SET Z=""""
- SET I=$PIECE(^(DG),U,6,99)
- IF I]""
- FOR W=2:1
- IF $PIECE(I,Z,W,99)=""
- QUIT
- SET V=$PIECE(I,Z,W)
- IF V]""
- IF $DATA(DCL(V))
- SET I=$PIECE(I,Z,1,W-1)_+DCL(V)_$PIECE(I,Z,W+1,99)
- SET W=W-1
- SET ^(DG)=$PIECE(^(DG),U,1,5)_U_I
- +2 QUIT
- +3 ;
- HT SET DLP=DX
- SET DCC=M
- SET DV=DW
- SET DNP(1)=DISMIN
- DO INIT^DIP5
- SET DISMIN=DNP(1)
- KILL DNP(1)
- +1 FOR %=0:0
- SET %=$ORDER(^DIPT("B",$PIECE($PIECE(DHD,"[",2),"]",1),%))
- IF %=""
- GOTO TT
- IF $DATA(^DIPT(%,0))
- IF $PIECE(^(0),U,4)=""!($PIECE(^(0),U,4)=DP)
- SET $PIECE(^(0),U,7)=DT
- QUIT
- +2 IF $DATA(^("ROU"))
- IF ^("ROU")[U
- IF '$DATA(^("DXS"))
- IF $DATA(^("IOM"))
- IF ^("IOM")'>IOM
- SET ^UTILITY($JOB,DV)="D "_^("ROU")
- SET DV=DV+1
- GOTO EHT
- +3 FOR V=0:0
- SET V=$ORDER(^DIPT(%,"DXS",V))
- IF V'>0
- QUIT
- FOR I=0:0
- SET I=$ORDER(^DIPT(%,"DXS",V,I))
- IF I'>0
- QUIT
- SET R=^(I)
- DO X
- SET ^UTILITY($JOB,V,I)=R
- +4 SET DX=-1
- SET DHD="^DIPT("_%_",""F"",DHT)"
- FOR DHT=0:0
- SET DHT=$ORDER(@DHD)
- IF DHT=""
- SET DHT=-1
- IF DHT'>0
- QUIT
- SET R=^(DHT)
- DO X
- Begin DoDot:1
- +5 NEW DNP
- DO ^DIL
- End DoDot:1
- IF DM
- DO UNSTACK^DIL
- +6 IF $LENGTH(Y)>1
- DO PX^DIL
- EHT SET DX=DLP
- SET DHD=DV-1
- SET M=M(DP(0))
- DO O
- SET DW=DV
- SET O=" N X"_O
- +1 IF DL
- SET M=M+1
- SET DILIOSL=IOSL-M
- SET ^(1)="X DIOT "_^UTILITY($JOB,1)_" K DIOT(2)"
- SET DIOT="I DC?.N,$Y X DIOT(1)"_O
- SET DIOT(1)="S DIOT(2)=1 F %=0:0 W ! Q:$Y>"_DILIOSL_"!($G(DDBRZIS))"
- SET M=M+DCC
- GOTO 0
- +2 SET M=DCC
- SET ^(1)=^UTILITY($JOB,1)_O
- TT SET DHD=$PIECE(DQI,"]",2)
- IF DHD=""
- GOTO 0
- SET DL=1
- GOTO HT
- +1 ;
- X SET W=$FIND(R,"X DXS(")
- SET Y=+$EXTRACT(R,W,999)
- SET X=+$EXTRACT(R,$FIND(R,C,W),999)
- IF W
- IF X
- IF Y
- SET R=$EXTRACT(R,1,W-5)_"^UTILITY($J,"_Y_C_X_$EXTRACT(R,W+$LENGTH(X)+$LENGTH(Y)+1,999)
- GOTO X
