DIL2 ;SFISC/GFT,XAK,TKW-PROCESS HDRS AND TRAILERS ;11:39 AM 13 Feb 2003
;;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.
;
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)
HEAD K DIOT S DW=2,(DQI,DV)=DHD,M=M(DP(0)) I DV?.P1"[".E1"]" D HT(DV?1"-".E) G 0
I 'DV G 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 DHTDXS="",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,DHTDXS
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=DHTDXS_" 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(DILTRAIL) S DLP=DX,DCC=M,DV=DW D
. N DISMIN D INIT^DIP5
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
S DHTDXS=$S($D(^("DXS")):" N DXS M DXS=^DIPT("_%_",""DXS"") ",1:"")
S DHT=$G(^DIPT(%,"ROU")) I DHT[U,$D(^("IOM")),^("IOM")'>IOM S ^UTILITY($J,DV)=DHTDXS_"D "_DHT,DV=DV+1 G EHT
S DX=-1,DHD="^DIPT("_%_",""F"",DHT)" F DHT=0:0 S DHT=$O(@DHD) Q:DHT'>0 S R=^(DHT) 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,DIP"_O
I DILTRAIL S M=M+1,DILIOSL=IOSL-M,^(1)="X DIOT "_^UTILITY($J,1)_" K DIOT(2)",DIOT="I DC?.N,$Y N DA S DA=D0 N D0 S D0=+$G(DIOT(""D0""),DA) X DIOT(1)"_O,DIOT(1)="S DIOT(2)=1 F W ! Q:$Y>"_DILIOSL_"!($G(DDBRZIS))",M=M+DCC Q
S M=DCC,^(1)=^UTILITY($J,1)_O
TT S DHD=$P(DQI,"]",2) I DHD]"" D HT(1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIL2 3094 printed Oct 16, 2024@18:49:52 Page 2
DIL2 ;SFISC/GFT,XAK,TKW-PROCESS HDRS AND TRAILERS ;11:39 AM 13 Feb 2003
+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 ;
+7 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
+8 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
+9 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:"")
+10 IF X'["D T"
SET X=X_" S DISTP=DISTP+1 D:'(DISTP#100) CSTP^DIO2"
+11 if $DATA(DISV)
SET X=X_" S ^DIBT("_DISV_",1,D0)="""""
+12 if X]""
SET DX=DX+1
SET ^UTILITY($JOB,99,DX)=$EXTRACT(X,2,999)
HEAD KILL DIOT
SET DW=2
SET (DQI,DV)=DHD
SET M=M(DP(0))
IF DV?.P1"[".E1"]"
DO HT(DV?1"-".E)
GOTO 0
+1 IF 'DV
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
+2 IF $DATA(DIPZ)
SET ^UTILITY($JOB,1)=^UTILITY($JOB,1)_" X ^UTILITY($J,2) D HEAD"_^DIPT(DIPZ,"ROU")_^("LAST")
GOTO 0
+3 SET DHTDXS=""
SET X=""
SET $PIECE(X,"-",$SELECT(IOM<244:IOM,1:244))="-"
+4 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,DHTDXS
+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=DHTDXS_" 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(DILTRAIL) SET DLP=DX
SET DCC=M
SET DV=DW
Begin DoDot:1
+1 NEW DISMIN
DO INIT^DIP5
End DoDot:1
+2 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
+3 SET DHTDXS=$SELECT($DATA(^("DXS")):" N DXS M DXS=^DIPT("_%_",""DXS"") ",1:"")
+4 SET DHT=$GET(^DIPT(%,"ROU"))
IF DHT[U
IF $DATA(^("IOM"))
IF ^("IOM")'>IOM
SET ^UTILITY($JOB,DV)=DHTDXS_"D "_DHT
SET DV=DV+1
GOTO EHT
+5 SET DX=-1
SET DHD="^DIPT("_%_",""F"",DHT)"
FOR DHT=0:0
SET DHT=$ORDER(@DHD)
if DHT'>0
QUIT
SET R=^(DHT)
Begin DoDot:1
+6 NEW DNP
DO ^DIL
End DoDot:1
if DM
DO UNSTACK^DIL
+7 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,DIP"_O
+1 IF DILTRAIL
SET M=M+1
SET DILIOSL=IOSL-M
SET ^(1)="X DIOT "_^UTILITY($JOB,1)_" K DIOT(2)"
SET DIOT="I DC?.N,$Y N DA S DA=D0 N D0 S D0=+$G(DIOT(""D0""),DA) X DIOT(1)"_O
SET DIOT(1)="S DIOT(2)=1 F W ! Q:$Y>"_DILIOSL_"!($G(DDBRZIS))"
SET M=M+DCC
QUIT
+2 SET M=DCC
SET ^(1)=^UTILITY($JOB,1)_O
TT SET DHD=$PIECE(DQI,"]",2)
IF DHD]""
DO HT(1)
+1 QUIT
