DGOIL2 ;ALB/AAS - CALCULATE LOS BY TRANSFER ; 28-SEPT-90
;;5.3;Registration;**93,498**;Aug 13, 1993
;
;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOIL2 3960 printed Oct 16, 2024@18:47:13 Page 2
DGOIL2 ;ALB/AAS - CALCULATE LOS BY TRANSFER ; 28-SEPT-90
+1 ;;5.3;Registration;**93,498**;Aug 13, 1993
+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
