DGUTL2 ;ALB/MJK/AAS - CALCULATE PASS DAYS UTILITY ; 8/5/02 5:48pm
;;5.3;Registration;**259,468**;Aug 13, 1993
;
;
CALC ; -- calculate days
; input: DGBDT := begin date
; DGEDT := end date
; DGADM := adm date
; DGPMCA:= corresponding. admission.
; DGMVTP:= type movements to count - see below
; output: DGREC := #days count asih
;
Q:'$D(DGMVTP)
S DGREC=0,DGXFRS="^UTILITY($J,""DGXFRS"")"
F DGI=DGADM:0 S DGI=$O(^DGPM("APCA",DFN,DGPMCA,DGI)) Q:'DGI!(DGI>DGEDT) I $D(^DGPM(+$O(^(DGI,0)),0)),$P(^(0),U,2)=2 S @DGXFRS@(DGI)=+$P(^(0),U,18)
F DGI=0:0 S DGI=$O(@DGXFRS@(DGI)) Q:'DGI I DGMVTP[(U_@DGXFRS@(DGI)_U) S DGA=$O(@DGXFRS@(DGI)) I $S('DGA:1,1:DGA'<DGBDT) S X2=$S(DGI<DGBDT:DGBDT,1:DGI),X1=$S('DGA:DGEDT,DGA<DGEDT:DGA,1:DGEDT) D ^%DTC S DGREC=DGREC+X Q:'DGA
CALCQ K @DGXFRS,DGXFRS,DGI Q
;
ASIH ;calculate asih days
S DGMVTP="^13^43^44^45^" G CALC
;
PL ;calculate total PASS and UA, AA leave days
S DGMVTP="^1^2^3^25^26^" G CALC
;
PLASIH ;calculate pass, leave and asih days
S DGMVTP="^1^2^3^25^26^13^43^44^45^" G CALC
;
APLD(DGPMCA,DGARR,DGBDT,DGEDT,DGMTYP) ;Return ASIH, pass & leave days and dates
;Input: DGPMCA=corresponding admission (pointer to file #405).
;Input: DGARR=output array name.
;Input: DGBDT=billing begin date.
;Input: DGEDT=billing end date.
;Input: DGMTYP=movement types (optional) where:
; 'A' = ASIH movements
; 'P' = pass and leave movements
; 'B' = both (default)
;
;Output: '-1' as an extrinisic value if input parameters are invalid.
; 1 as an extrinisic value if input parameters are valid.
; Total ASIH,PASS & LEAVE days returned as array (DGARR).
;
;Output: DGARR array where:
; DGARR(0)=Total days^Begin date^End date.
; DGARR(Movement_Ien Pointer to 405)=Movement_start_date^Movement_end_date^
; Total_days^Movement_type(Pointer to 405.2)^(used only to denote a return
; movement set as "RTN")^Return_Movement_type^Return_Movement_Ien.
;
;validate input
N DFN,DGMOV,DGMVTP,SOL,EOL,DGM0,TDGI,TDGM,DGI,DGM,X1,X2,DGCT,DGDIS,X
N DGPL,DGRC,MDT,RTN,NDGM,PROCESS,RTN,XSOL,XSOL,XDGMOV,ISOL,RCNT,DGRTMV,DGIB K DGARR
S DGPMCA=$G(DGPMCA),DGMTYP=$G(DGMTYP),(DGBDT)=($G(DGBDT)\1),DGEDT=($G(DGEDT)\1)
I DGBDT<1!(DGEDT<1)!(DGPMCA="")!'$D(^DGPM(DGPMCA,0))!(DGBDT>DGEDT) Q -1
I DGEDT>DT Q -1 ; no future billing dates.
;initialize variables
S DGMVTP=$S(DGMTYP="A":"^13^43^44^45^",DGMTYP="P":"^1^2^3^25^26^",1:"^1^2^3^25^26^13^43^44^45^")
S DGRTMV=$S(DGMTYP="A":"^14^",DGMTYP="P":"^22^23^24^",1:"^14^22^23^24^")
S DGPL="^1^2^3^25^26^13^43^44^45^"
S DGCT=0,DGI=0,DGMOV="^TMP(""DGMOV"",$J)" K ^TMP("DGMOV",$J)
S DGM0=^DGPM(+DGPMCA,0),DFN=$P(DGM0,U,3) Q:$P(DGM0,U,2)'=1 -1
S DGDIS=$P($G(^DGPM(+$P(DGM0,U,17),0)),U) I DGDIS>1 D
.I DGEDT>DGDIS S DGEDT=DGDIS
.S DGMVTP=DGMVTP_$P(^DGPM($P(DGM0,U,17),0),U,18)_"^"
I DGDIS,DGBDT'<DGDIS Q -1 ; date range starts after discharge
S DGRC=0,DGI=DGBDT F S DGI=$O(^DGPM("APCA",DFN,DGPMCA,DGI)) Q:'DGI!(DGI\1>DGEDT) D
.S DGM=$O(^DGPM("APCA",DFN,DGPMCA,DGI,0)),DGM0=$G(^DGPM(DGM,0)),MDT=DGM0\1
.Q:MDT>DGEDT I $P(DGM0,U,2)=2!($P(DGM0,U,2)=3) S @DGMOV@(DGI,DGM)=DGM0 S DGRC=DGRC+1
;Examine movements movements for selected movement option.
I DGRC=0 S (SOL,DGM0)=DGBDT,EOL=DGEDT,DGIB=0 D IBCHK G ENDREC ; interm billcheck
N DGRTNCHK,DG,DGK,DGB S (RTN,DGI,RCNT)=0 F DG=1:1 S DGI=$O(@DGMOV@(DGI)) Q:'DGI S RCNT=RCNT+1 D
.S DGIB=0,NDGM="",EOL=0,DGM=$O(@DGMOV@(DGI,0)),NDGM=DGI,NDGM=$O(@DGMOV@(NDGM))
.S DGM0=@DGMOV@(DGI,DGM),SOL=$P(DGM0,U,1)
.S PROCESS=$S(DGMVTP'[(U_$P(DGM0,U,18)_U):0,$P(DGM0,U,2)=3:1,1:1)
.S PROCESS=$S(DGRTMV[(U_$P(DGM0,U,18)_U)&(RCNT=1):1,1:PROCESS)
.Q:'PROCESS
.S DGK="",DGB=""
.F S DGK=$O(DGRTNCHK(DGK)) Q:DGK="" I DGRTNCHK(DGK)[(DGI_DGM) S DGB=1 Q
.Q:DGB
.S TDGI=DGI F S TDGI=$O(@DGMOV@(TDGI)) Q:'TDGI!(EOL) D
..S TDGM=$O(@DGMOV@(TDGI,0)) I DGRTMV[(U_$P(@DGMOV@(TDGI,TDGM),U,18)_U) D
...S RTN=U_"RTN"_U_($P((@DGMOV@(TDGI,TDGM)),U,18))_U_TDGM,EOL=1
...S DGRTNCHK(DG)=TDGI_TDGM
.S EOL=$S('NDGM:DGEDT,NDGM>DGEDT:DGEDT,1:NDGM) D
..S SOL=$S(SOL<DGBDT:DGBDT,$P(DGM0,U,2)=3&(RCNT=1):DGBDT,1:SOL)
..I RCNT=1 D IBCHK I DGRTMV[(U_$P(DGM0,U,18)_U) D
...S RTN=U_"RTN"_U_($P(DGM0,U,18))_U_DGM
..I RCNT=1,$P(DGM0,U,2)=3,DGIB=0 Q
..S X2=SOL,X1=EOL D ^%DTC I RTN=0,(EOL\1)'=(DGDIS\1),(SOL\1)'=(DGDIS\1),EOL'=NDGM S X=X+1
..I X=0 S RTN=0 Q
..S DGARR(DGM)=SOL_U_EOL_U_X_U_$P(DGM0,U,18)
..S:RTN'=0 DGARR(DGM)=DGARR(DGM)_RTN,RTN=0
..S DGCT=DGCT+X ;Grand total
ENDREC S DGARR(0)=DGCT_U_DGBDT_U_DGEDT K ^TMP("DGMOV",$J)
Q 1
IBCHK S ISOL=DGM0\1 S ISOL=$O(^DGPM("APCA",DFN,DGPMCA,ISOL),-1) I ISOL D
.S XDGMOV="" S XDGMOV=$O(^DGPM("APCA",DFN,DGPMCA,ISOL,XDGMOV)) Q:XDGMOV="" D
..I DGMVTP[(U_$P(^DGPM(XDGMOV,0),U,18)_U) S DGIB=1 I DGRC S EOL=$S($P(DGM0,U,2)=3&(RCNT=1):EOL,1:SOL),SOL=DGBDT ;interim billing ch
..I DGRC=0,DGIB=1 S X2=SOL,X1=EOL D ^%DTC S DGCT=X,DGCT=DGCT+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGUTL2 5036 printed Dec 13, 2024@02:59:08 Page 2
DGUTL2 ;ALB/MJK/AAS - CALCULATE PASS DAYS UTILITY ; 8/5/02 5:48pm
+1 ;;5.3;Registration;**259,468**;Aug 13, 1993
+2 ;
+3 ;
CALC ; -- calculate days
+1 ; input: DGBDT := begin date
+2 ; DGEDT := end date
+3 ; DGADM := adm date
+4 ; DGPMCA:= corresponding. admission.
+5 ; DGMVTP:= type movements to count - see below
+6 ; output: DGREC := #days count asih
+7 ;
+8 if '$DATA(DGMVTP)
QUIT
+9 SET DGREC=0
SET DGXFRS="^UTILITY($J,""DGXFRS"")"
+10 FOR DGI=DGADM:0
SET DGI=$ORDER(^DGPM("APCA",DFN,DGPMCA,DGI))
if 'DGI!(DGI>DGEDT)
QUIT
IF $DATA(^DGPM(+$ORDER(^(DGI,0)),0))
IF $PIECE(^(0),U,2)=2
SET @DGXFRS@(DGI)=+$PIECE(^(0),U,18)
+11 FOR DGI=0:0
SET DGI=$ORDER(@DGXFRS@(DGI))
if 'DGI
QUIT
IF DGMVTP[(U_@DGXFRS@(DGI)_U)
SET DGA=$ORDER(@DGXFRS@(DGI))
IF $SELECT('DGA:1,1:DGA'<DGBDT)
SET X2=$SELECT(DGI<DGBDT:DGBDT,1:DGI)
SET X1=$SELECT('DGA:DGEDT,DGA<DGEDT:DGA,1:DGEDT)
DO ^%DTC
SET DGREC=DGREC+X
if 'DGA
QUIT
CALCQ KILL @DGXFRS,DGXFRS,DGI
QUIT
+1 ;
ASIH ;calculate asih days
+1 SET DGMVTP="^13^43^44^45^"
GOTO CALC
+2 ;
PL ;calculate total PASS and UA, AA leave days
+1 SET DGMVTP="^1^2^3^25^26^"
GOTO CALC
+2 ;
PLASIH ;calculate pass, leave and asih days
+1 SET DGMVTP="^1^2^3^25^26^13^43^44^45^"
GOTO CALC
+2 ;
APLD(DGPMCA,DGARR,DGBDT,DGEDT,DGMTYP) ;Return ASIH, pass & leave days and dates
+1 ;Input: DGPMCA=corresponding admission (pointer to file #405).
+2 ;Input: DGARR=output array name.
+3 ;Input: DGBDT=billing begin date.
+4 ;Input: DGEDT=billing end date.
+5 ;Input: DGMTYP=movement types (optional) where:
+6 ; 'A' = ASIH movements
+7 ; 'P' = pass and leave movements
+8 ; 'B' = both (default)
+9 ;
+10 ;Output: '-1' as an extrinisic value if input parameters are invalid.
+11 ; 1 as an extrinisic value if input parameters are valid.
+12 ; Total ASIH,PASS & LEAVE days returned as array (DGARR).
+13 ;
+14 ;Output: DGARR array where:
+15 ; DGARR(0)=Total days^Begin date^End date.
+16 ; DGARR(Movement_Ien Pointer to 405)=Movement_start_date^Movement_end_date^
+17 ; Total_days^Movement_type(Pointer to 405.2)^(used only to denote a return
+18 ; movement set as "RTN")^Return_Movement_type^Return_Movement_Ien.
+19 ;
+20 ;validate input
+21 NEW DFN,DGMOV,DGMVTP,SOL,EOL,DGM0,TDGI,TDGM,DGI,DGM,X1,X2,DGCT,DGDIS,X
+22 NEW DGPL,DGRC,MDT,RTN,NDGM,PROCESS,RTN,XSOL,XSOL,XDGMOV,ISOL,RCNT,DGRTMV,DGIB
KILL DGARR
+23 SET DGPMCA=$GET(DGPMCA)
SET DGMTYP=$GET(DGMTYP)
SET (DGBDT)=($GET(DGBDT)\1)
SET DGEDT=($GET(DGEDT)\1)
+24 IF DGBDT<1!(DGEDT<1)!(DGPMCA="")!'$DATA(^DGPM(DGPMCA,0))!(DGBDT>DGEDT)
QUIT -1
+25 ; no future billing dates.
IF DGEDT>DT
QUIT -1
+26 ;initialize variables
+27 SET DGMVTP=$SELECT(DGMTYP="A":"^13^43^44^45^",DGMTYP="P":"^1^2^3^25^26^",1:"^1^2^3^25^26^13^43^44^45^")
+28 SET DGRTMV=$SELECT(DGMTYP="A":"^14^",DGMTYP="P":"^22^23^24^",1:"^14^22^23^24^")
+29 SET DGPL="^1^2^3^25^26^13^43^44^45^"
+30 SET DGCT=0
SET DGI=0
SET DGMOV="^TMP(""DGMOV"",$J)"
KILL ^TMP("DGMOV",$JOB)
+31 SET DGM0=^DGPM(+DGPMCA,0)
SET DFN=$PIECE(DGM0,U,3)
if $PIECE(DGM0,U,2)'=1
QUIT -1
+32 SET DGDIS=$PIECE($GET(^DGPM(+$PIECE(DGM0,U,17),0)),U)
IF DGDIS>1
Begin DoDot:1
+33 IF DGEDT>DGDIS
SET DGEDT=DGDIS
+34 SET DGMVTP=DGMVTP_$PIECE(^DGPM($PIECE(DGM0,U,17),0),U,18)_"^"
End DoDot:1
+35 ; date range starts after discharge
IF DGDIS
IF DGBDT'<DGDIS
QUIT -1
+36 SET DGRC=0
SET DGI=DGBDT
FOR
SET DGI=$ORDER(^DGPM("APCA",DFN,DGPMCA,DGI))
if 'DGI!(DGI\1>DGEDT)
QUIT
Begin DoDot:1
+37 SET DGM=$ORDER(^DGPM("APCA",DFN,DGPMCA,DGI,0))
SET DGM0=$GET(^DGPM(DGM,0))
SET MDT=DGM0\1
+38 if MDT>DGEDT
QUIT
IF $PIECE(DGM0,U,2)=2!($PIECE(DGM0,U,2)=3)
SET @DGMOV@(DGI,DGM)=DGM0
SET DGRC=DGRC+1
End DoDot:1
+39 ;Examine movements movements for selected movement option.
+40 ; interm billcheck
IF DGRC=0
SET (SOL,DGM0)=DGBDT
SET EOL=DGEDT
SET DGIB=0
DO IBCHK
GOTO ENDREC
+41 NEW DGRTNCHK,DG,DGK,DGB
SET (RTN,DGI,RCNT)=0
FOR DG=1:1
SET DGI=$ORDER(@DGMOV@(DGI))
if 'DGI
QUIT
SET RCNT=RCNT+1
Begin DoDot:1
+42 SET DGIB=0
SET NDGM=""
SET EOL=0
SET DGM=$ORDER(@DGMOV@(DGI,0))
SET NDGM=DGI
SET NDGM=$ORDER(@DGMOV@(NDGM))
+43 SET DGM0=@DGMOV@(DGI,DGM)
SET SOL=$PIECE(DGM0,U,1)
+44 SET PROCESS=$SELECT(DGMVTP'[(U_$PIECE(DGM0,U,18)_U):0,$PIECE(DGM0,U,2)=3:1,1:1)
+45 SET PROCESS=$SELECT(DGRTMV[(U_$PIECE(DGM0,U,18)_U)&(RCNT=1):1,1:PROCESS)
+46 if 'PROCESS
QUIT
+47 SET DGK=""
SET DGB=""
+48 FOR
SET DGK=$ORDER(DGRTNCHK(DGK))
if DGK=""
QUIT
IF DGRTNCHK(DGK)[(DGI_DGM)
SET DGB=1
QUIT
+49 if DGB
QUIT
+50 SET TDGI=DGI
FOR
SET TDGI=$ORDER(@DGMOV@(TDGI))
if 'TDGI!(EOL)
QUIT
Begin DoDot:2
+51 SET TDGM=$ORDER(@DGMOV@(TDGI,0))
IF DGRTMV[(U_$PIECE(@DGMOV@(TDGI,TDGM),U,18)_U)
Begin DoDot:3
+52 SET RTN=U_"RTN"_U_($PIECE((@DGMOV@(TDGI,TDGM)),U,18))_U_TDGM
SET EOL=1
+53 SET DGRTNCHK(DG)=TDGI_TDGM
End DoDot:3
End DoDot:2
+54 SET EOL=$SELECT('NDGM:DGEDT,NDGM>DGEDT:DGEDT,1:NDGM)
Begin DoDot:2
+55 SET SOL=$SELECT(SOL<DGBDT:DGBDT,$PIECE(DGM0,U,2)=3&(RCNT=1):DGBDT,1:SOL)
+56 IF RCNT=1
DO IBCHK
IF DGRTMV[(U_$PIECE(DGM0,U,18)_U)
Begin DoDot:3
+57 SET RTN=U_"RTN"_U_($PIECE(DGM0,U,18))_U_DGM
End DoDot:3
+58 IF RCNT=1
IF $PIECE(DGM0,U,2)=3
IF DGIB=0
QUIT
+59 SET X2=SOL
SET X1=EOL
DO ^%DTC
IF RTN=0
IF (EOL\1)'=(DGDIS\1)
IF (SOL\1)'=(DGDIS\1)
IF EOL'=NDGM
SET X=X+1
+60 IF X=0
SET RTN=0
QUIT
+61 SET DGARR(DGM)=SOL_U_EOL_U_X_U_$PIECE(DGM0,U,18)
+62 if RTN'=0
SET DGARR(DGM)=DGARR(DGM)_RTN
SET RTN=0
+63 ;Grand total
SET DGCT=DGCT+X
End DoDot:2
End DoDot:1
ENDREC SET DGARR(0)=DGCT_U_DGBDT_U_DGEDT
KILL ^TMP("DGMOV",$JOB)
+1 QUIT 1
IBCHK SET ISOL=DGM0\1
SET ISOL=$ORDER(^DGPM("APCA",DFN,DGPMCA,ISOL),-1)
IF ISOL
Begin DoDot:1
+1 SET XDGMOV=""
SET XDGMOV=$ORDER(^DGPM("APCA",DFN,DGPMCA,ISOL,XDGMOV))
if XDGMOV=""
QUIT
Begin DoDot:2
+2 ;interim billing ch
IF DGMVTP[(U_$PIECE(^DGPM(XDGMOV,0),U,18)_U)
SET DGIB=1
IF DGRC
SET EOL=$SELECT($PIECE(DGM0,U,2)=3&(RCNT=1):EOL,1:SOL)
SET SOL=DGBDT
+3 IF DGRC=0
IF DGIB=1
SET X2=SOL
SET X1=EOL
DO ^%DTC
SET DGCT=X
SET DGCT=DGCT+1
End DoDot:2
End DoDot:1
+4 QUIT
