Routine: DIL2

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

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)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIL2   3094     printed  Feb 19, 2025@00:15:33                                                                                                                                                                                                        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

DIL2.m