- 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 Feb 19, 2025@00:25:09 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
