DGOIL2.m

DGOIL2 ;ALB/AAS - CALCULATE LOS BY TRANSFER ; 28-SEPT-90

 ;;5.3;Registration;**93,498,1015**;Aug 13, 1993;Build 21

 ;

 ;INPUT   -   Admission ifn in DGPMIFN - call EN^

 ;

 ;OUTPUT  - x(t)=net los^auth absence days^pass days^unauth days^asih days^gross los^trf date^ward

 ;          x3=sum of x(t's)

 ;

EN N T,I S (LOP,LOA,LOUA,LOAS)=0

 S (X,X3)="0^0^0^0^0^0^0"

 I $S('$D(DGPMIFN):1,'$D(^DGPM(+DGPMIFN,0)):1,$P(^(0),"^",2)'=1:1,1:0) G END

 S B=^DGPM(DGPMIFN,0),DFN=$P(B,"^",3),A=+B

 I $P(B,"^",22) S:$L(A)=7 A=A_"." S A=A_"000000",A=$E(A,1,14)_$P(B,"^",22)

ASIH S DGASIH="" I $P(B,"^",18)=40,$P(B,"^",21),$P(^DGPM($P(B,"^",21),0),"^",14) S ADM=^DGPM($P(^DGPM($P(B,"^",21),0),"^",14),0),DIS=$P(ADM,"^",17) I DIS]"",$D(^DGPM(DIS,0)),+^(0)>DT S DGASIH="+" ;currently asih flag

 D MAX

 ;

 S (I,DGT)=1

ADM F DGT=DGT:1 S A1=A,DGPMIFN1=$O(^DGPM("APCA",DFN,DGPMIFN,A,0)) Q:'DGPMIFN1!('A)!('I)  D TRANS

 Q:$D(DGPMIFN(1))

 S $P(X3,"^",9)=DGASIH

 S $P(X3,"^",10)=$S($P($G(^DGPM(DGPMIFN,"DIR")),"^",1)'=0:"!",1:"")

 G END

 ;

EN1 ; - entry to find los for one transfer

 ; - input DGPMIFN1 = transfer

 ; - output in X(t) if '$d(DGT) t=1

 ;

 I $S('$D(DGPMIFN1):1,'$D(^DGPM(DGPMIFN1,0)):1,$P(^(0),"^",2)>2:1,1:0) S DGOUT=1 G EN1Q

 S DGPMIFN=$P(^DGPM(DGPMIFN1,0),"^",14) I $S('DGPMIFN:1,'$D(^DGPM(DGPMIFN,0)):1,1:0) S DGOUT=1 G EN1Q

 S B=^DGPM(DGPMIFN,0)

 S DGT=1 D MAX

TRANS S (DGOUT,LOP,LOA,LOUA,LOAS)=0

 S X(DGT)="0^0^0^0^0^0^0^0^"

 S B(DGT)=^DGPM(DGPMIFN1,0)

 S DGWRD=+$P(B(DGT),"^",6) I +DGWRD,$D(^DIC(42,+DGWRD,0)) S DGWRD=$P(^(0),"^")

 E  S DGWRD=""

 ;

 S DGDONE=0

 F I=A:0 S I=$O(^DGPM("APCA",DFN,DGPMIFN,I)) Q:'I  S:$E(I,1,$L(D))'=D A=I S DGS=$O(^(I,0)) I $D(^DGPM(+DGS,0)) S Z=DGS,DGS=^(0) I "^1^2^3^4^25^26^13^14^43^44^45^"[("^"_$P(DGS,"^",18)_"^") S X2=+DGS,DGS=("^"_$P(DGS,"^",18)_"^") D ABS Q:'I!DGOUT

 I 'DGDONE,'I S A1=A,A=D ;end of movements, a1=start of last trf, a=dschrg or now

 D TRFTOT

 I $D(DGS),"^13^"[DGS D ^DGOIL3

EN1Q K DGWRD

 Q

 ;

ABS ; - if patient was on absence, find return.

 ; - DGS = mvt type at start of absence

 ; - DGE = mvt type at end of absence

 ;

 I "^43^"[DGS S DGOF=$S($P(^DGPM(Z,0),"^",5):$S($D(^DIC(4,$P(^DGPM(Z,0),"^",5),0)):$P(^(0),"^"),1:"UNK"),1:"UNK")

 I "^4^13^43^"[DGS S DGOUT=1 Q  ;start new transfers

 ;

 I "^14^"[DGS S:$D(DGOF) DGOFF=1 S X1=A,X2=A1 D ^%DTC S LOAS=LOAS+X,DGOUT=1 Q

 ;

TF S X1=0 F I=I:0 S I=$O(^DGPM("APCA",DFN,DGPMIFN,I)) Q:'I  S DGE=$O(^(I,0)) I $D(^DGPM(+DGE,0)) S DGE=^(0) I "^4^13^14^22^23^24^25^26^43^"[("^"_$P(DGE,"^",18)_"^") S (X1,DGET)=+DGE,DGE="^"_$P(DGE,"^",18)_"^" Q

 ;

 I 'X1 S (A,X1)=D D ^%DTC S DGOUT=1 D NORET Q  ;if no return from absence use discharge or now 

 D ^%DTC

 ;

 ;if 22 or 26 add time in unauth

 I "^22^26^"[DGE S LOUA=LOUA+X,A=A1

 ;

 ;if 23 add time in pass

 I "^23^"[DGE S LOP=LOP+X,A=A1

 ;

 ;if 24 or 25 add time in auth

 I "^24^25^"[DGE S LOA=LOA+X,A=A1

 ;

 I "^14^"[DGE S LOAS=LOAS+X,DGOUT=1

 ;

 ;if 25 or 26 sets tranf to and looks for next return

 I "^25^26"[DGE S DGS=DGE,X2=DGET G TF

 ;

 I "^14^44^"[DGE S DGOUT=1 Q  ;I wonder if this is really necessary?

 Q

 ;

TOT ; -- total los from transfer x(t) into x3

 F JJ=1:1:6 S $P(X3,"^",JJ)=$P(X3,"^",JJ)+($P(X(DGT),"^",JJ))

 F JJ=7:1:8 S $P(X3,"^",JJ)=$P(X(DGT),"^",JJ)

 Q

 ;

TRFTOT ; los for transfer, set x(t)

 S X1=A,X2=A1 D ^%DTC

 S X(DGT)=(X-(LOA+LOUA))_"^"_LOA_"^"_LOP_"^"_LOUA_"^"_$S($D(DGPMIFN(1)):X,1:LOAS)_"^"_X_"^"_A1_"^"_$S($D(DGOFF):DGOF,1:DGWRD),DGOUT=1 K:$D(DGOFF) DGOFF,DGOF

 D TOT

 Q

 ;

NORET ;  -- If discharge while absent find absence up to discharge

 S DGDONE=1

 I "^1^"[DGS S LOP=LOP+X

 I "^2^26^"[DGS S LOA=LOA+X

 I "^3^25^"[DGS S LOUA=LOUA+X

 I "^14^43^44^45^"[DGS S LOAS=LOAS+X

 Q

END K A,A1,B,D,DGDONE,DGE,DGET,DGMAX,DGOUT,DGPMIFN,DGPMIFN1,DGS,DGT,DGWRD,I,JJ,LOA,LOAS,LOP,LOUA,T,X1,X2

 Q

MAX D NOW^%DTC S D=$S($D(^DGPM(+$P(B,"^",17),0)):+^(0),1:0) S D=$S('D:%,D>%:%,1:D) S X1=D,X2=A D ^%DTC S DGMAX=$S(X:X,1:1)

 Q

DGOIL2    ;ALB/AAS - CALCULATE LOS BY TRANSFER ; 28-SEPT-90

 +1       ;;5.3;Registration;**93,498,1015**;Aug 13, 1993;Build 21

 +2       ;

 +3       ;INPUT   -   Admission ifn in DGPMIFN - call EN^

 +4       ;

 +5       ;OUTPUT  - x(t)=net los^auth absence days^pass days^unauth days^asih days^gross los^trf date^ward

 +6       ;          x3=sum of x(t's)

 +7       ;

EN         NEW T,I

           SET (LOP,LOA,LOUA,LOAS)=0

 +1        SET (X,X3)="0^0^0^0^0^0^0"

 +2        IF $SELECT('$DATA(DGPMIFN):1,'$DATA(^DGPM(+DGPMIFN,0)):1,$PIECE(^(0),"^",2)'=1:1,1:0)

               GOTO END

 +3        SET B=^DGPM(DGPMIFN,0)

           SET DFN=$PIECE(B,"^",3)

           SET A=+B

 +4        IF $PIECE(B,"^",22)

               IF $LENGTH(A)=7

                   SET A=A_"."

               SET A=A_"000000"

               SET A=$EXTRACT(A,1,14)_$PIECE(B,"^",22)

ASIH      ;currently asih flag

           SET DGASIH=""

           IF $PIECE(B,"^",18)=40

               IF $PIECE(B,"^",21)

                   IF $PIECE(^DGPM($PIECE(B,"^",21),0),"^",14)

                       SET ADM=^DGPM($PIECE(^DGPM($PIECE(B,"^",21),0),"^",14),0)

                       SET DIS=$PIECE(ADM,"^",17)

                       IF DIS]""

                           IF $DATA(^DGPM(DIS,0))

                               IF +^(0)>DT

                                   SET DGASIH="+"

 +1        DO MAX

 +2       ;

 +3        SET (I,DGT)=1

ADM        FOR DGT=DGT:1

               SET A1=A

               SET DGPMIFN1=$ORDER(^DGPM("APCA",DFN,DGPMIFN,A,0))

               IF 'DGPMIFN1!('A)!('I)

                   QUIT 

               DO TRANS

 +1        IF $DATA(DGPMIFN(1))

               QUIT 

 +2        SET $PIECE(X3,"^",9)=DGASIH

 +3        SET $PIECE(X3,"^",10)=$SELECT($PIECE($GET(^DGPM(DGPMIFN,"DIR")),"^",1)'=0:"!",1:"")

 +4        GOTO END

 +5       ;

EN1       ; - entry to find los for one transfer

 +1       ; - input DGPMIFN1 = transfer

 +2       ; - output in X(t) if '$d(DGT) t=1

 +3       ;

 +4        IF $SELECT('$DATA(DGPMIFN1):1,'$DATA(^DGPM(DGPMIFN1,0)):1,$PIECE(^(0),"^",2)>2:1,1:0)

               SET DGOUT=1

               GOTO EN1Q

 +5        SET DGPMIFN=$PIECE(^DGPM(DGPMIFN1,0),"^",14)

           IF $SELECT('DGPMIFN:1,'$DATA(^DGPM(DGPMIFN,0)):1,1:0)

               SET DGOUT=1

               GOTO EN1Q

 +6        SET B=^DGPM(DGPMIFN,0)

 +7        SET DGT=1

           DO MAX

TRANS      SET (DGOUT,LOP,LOA,LOUA,LOAS)=0

 +1        SET X(DGT)="0^0^0^0^0^0^0^0^"

 +2        SET B(DGT)=^DGPM(DGPMIFN1,0)

 +3        SET DGWRD=+$PIECE(B(DGT),"^",6)

           IF +DGWRD

               IF $DATA(^DIC(42,+DGWRD,0))

                   SET DGWRD=$PIECE(^(0),"^")

 +4       IF '$TEST

               SET DGWRD=""

 +5       ;

 +6        SET DGDONE=0

 +7        FOR I=A:0

               SET I=$ORDER(^DGPM("APCA",DFN,DGPMIFN,I))

               IF 'I

                   QUIT 

               IF $EXTRACT(I,1,$LENGTH(D))'=D

                   SET A=I

               SET DGS=$ORDER(^(I,0))

               IF $DATA(^DGPM(+DGS,0))

                   SET Z=DGS

                   SET DGS=^(0)

                   IF "^1^2^3^4^25^26^13^14^43^44^45^"[("^"_$PIECE(DGS,"^",18)_"^")

                       SET X2=+DGS

                       SET DGS=("^"_$PIECE(DGS,"^",18)_"^")

                       DO ABS

                       IF 'I!DGOUT

                           QUIT 

 +8       ;end of movements, a1=start of last trf, a=dschrg or now

           IF 'DGDONE

               IF 'I

                   SET A1=A

                   SET A=D

 +9        DO TRFTOT

 +10       IF $DATA(DGS)

               IF "^13^"[DGS

                   DO ^DGOIL3

EN1Q       KILL DGWRD

 +1        QUIT 

 +2       ;

ABS       ; - if patient was on absence, find return.

 +1       ; - DGS = mvt type at start of absence

 +2       ; - DGE = mvt type at end of absence

 +3       ;

 +4        IF "^43^"[DGS

               SET DGOF=$SELECT($PIECE(^DGPM(Z,0),"^",5):$SELECT($DATA(^DIC(4,$PIECE(^DGPM(Z,0),"^",5),0)):$PIECE(^(0),"^"),1:"UNK"),1:"UNK")

 +5       ;start new transfers

           IF "^4^13^43^"[DGS

               SET DGOUT=1

               QUIT 

 +6       ;

 +7        IF "^14^"[DGS

               IF $DATA(DGOF)

                   SET DGOFF=1

               SET X1=A

               SET X2=A1

               DO ^%DTC

               SET LOAS=LOAS+X

               SET DGOUT=1

               QUIT 

 +8       ;

TF         SET X1=0

           FOR I=I:0

               SET I=$ORDER(^DGPM("APCA",DFN,DGPMIFN,I))

               IF 'I

                   QUIT 

               SET DGE=$ORDER(^(I,0))

               IF $DATA(^DGPM(+DGE,0))

                   SET DGE=^(0)

                   IF "^4^13^14^22^23^24^25^26^43^"[("^"_$PIECE(DGE,"^",18)_"^")

                       SET (X1,DGET)=+DGE

                       SET DGE="^"_$PIECE(DGE,"^",18)_"^"

                       QUIT 

 +1       ;

 +2       ;if no return from absence use discharge or now 

           IF 'X1

               SET (A,X1)=D

               DO ^%DTC

               SET DGOUT=1

               DO NORET

               QUIT 

 +3        DO ^%DTC

 +4       ;

 +5       ;if 22 or 26 add time in unauth

 +6        IF "^22^26^"[DGE

               SET LOUA=LOUA+X

               SET A=A1

 +7       ;

 +8       ;if 23 add time in pass

 +9        IF "^23^"[DGE

               SET LOP=LOP+X

               SET A=A1

 +10      ;

 +11      ;if 24 or 25 add time in auth

 +12       IF "^24^25^"[DGE

               SET LOA=LOA+X

               SET A=A1

 +13      ;

 +14       IF "^14^"[DGE

               SET LOAS=LOAS+X

               SET DGOUT=1

 +15      ;

 +16      ;if 25 or 26 sets tranf to and looks for next return

 +17       IF "^25^26"[DGE

               SET DGS=DGE

               SET X2=DGET

               GOTO TF

 +18      ;

 +19      ;I wonder if this is really necessary?

           IF "^14^44^"[DGE

               SET DGOUT=1

               QUIT 

 +20       QUIT 

 +21      ;

TOT       ; -- total los from transfer x(t) into x3

 +1        FOR JJ=1:1:6

               SET $PIECE(X3,"^",JJ)=$PIECE(X3,"^",JJ)+($PIECE(X(DGT),"^",JJ))

 +2        FOR JJ=7:1:8

               SET $PIECE(X3,"^",JJ)=$PIECE(X(DGT),"^",JJ)

 +3        QUIT 

 +4       ;

TRFTOT    ; los for transfer, set x(t)

 +1        SET X1=A

           SET X2=A1

           DO ^%DTC

 +2        SET X(DGT)=(X-(LOA+LOUA))_"^"_LOA_"^"_LOP_"^"_LOUA_"^"_$SELECT($DATA(DGPMIFN(1)):X,1:LOAS)_"^"_X_"^"_A1_"^"_$SELECT($DATA(DGOFF):DGOF,1:DGWRD)

           SET DGOUT=1

           IF $DATA(DGOFF)

               KILL DGOFF,DGOF

 +3        DO TOT

 +4        QUIT 

 +5       ;

NORET     ;  -- If discharge while absent find absence up to discharge

 +1        SET DGDONE=1

 +2        IF "^1^"[DGS

               SET LOP=LOP+X

 +3        IF "^2^26^"[DGS

               SET LOA=LOA+X

 +4        IF "^3^25^"[DGS

               SET LOUA=LOUA+X

 +5        IF "^14^43^44^45^"[DGS

               SET LOAS=LOAS+X

 +6        QUIT 

END        KILL A,A1,B,D,DGDONE,DGE,DGET,DGMAX,DGOUT,DGPMIFN,DGPMIFN1,DGS,DGT,DGWRD,I,JJ,LOA,LOAS,LOP,LOUA,T,X1,X2

 +1        QUIT 

MAX        DO NOW^%DTC

           SET D=$SELECT($DATA(^DGPM(+$PIECE(B,"^",17),0)):+^(0),1:0)

           SET D=$SELECT('D:%,D>%:%,1:D)

           SET X1=D

           SET X2=A

           DO ^%DTC

           SET DGMAX=$SELECT(X:X,1:1)

 +1        QUIT