IBAECU4 ;WOIFO/SS - LTC PHASE 2 UTILITIES ; 20-FEB-02
;;2.0;INTEGRATED BILLING;**171,176,728**;21-MAR-94;Build 14
;;Per VHA Directive 10-93-142, this routine should not be modified.
;** LTC Clock related utilities **
;Makes FM date from any date of month or YEAR_MONTH and Day #
MKDATE(IBYM,IBD) ;
Q $E(IBYM,1,5)_$S(IBD<10:"0"_IBD,1:IBD)
;substracts (CHNG<0) or adds (CHNG>0) days to date
;DATE - date in FM format
CHNGDATE(DATE,CHNG) ;
N X,X1,X2
S X1=DATE,X2=CHNG D C^%DTC
Q X
;adjusts clocks
; "C" - cancel it
; "P" - 1) mark patient as "processed" i.e. we should
; set CURRENT EVENTS DATE=""
; or to 1st day of the next month if the patient is not disharged yet
; 2)adjust 180 days clocks
;.IBCLKADJ - array with info regarding clock adjustment
;IBCLKIEN - ien of file 351.81
;IBDFN - dfn of the patient
;IBINPLD - returned value of $$ISINPAT^IBAECU2 for the last date of the month
; if "^" - no admission for the last day of the
; processed month, set CURRENT EVENTS DATE=""
; if "number^" then we have inpatient LTC on the last day,
; set CURRENT EVENTS DATE=1st day of the following month
;IBEND the last date of the month
CLCKADJ(IBCLKADJ,IBCLIEN,IBDFN,IBINPLD,IBEND) ;
N IBNEWDT
;check if it is the 1st MJ then do not cancel clock and do not clear CURRENT EVENTS field
I $G(IBMJ1ST)="MJ1ST" Q:IBCLKADJ="C" Q:+IBINPLD=0
S IBNEWDT=""
;"C": cancel clock
I IBCLKADJ="C" D Q
. L +^IBA(351.81,0):10 I '$T D Q ;quit
. . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: not cancelled")
. D CANCCLCK(IBCLIEN,IBDFN) ;cancel clock
. D CLKSTAMP(IBCLIEN,IBDFN)
. L -^IBA(351.81,0)
;"P": mark that the patient has been processed succesfully
I IBCLKADJ="P" D Q
. L +^IBA(351.81,0):10 I '$T D Q ;quit
. . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: no current event change")
. I +IBINPLD>0 S IBNEWDT=$$CHNGDATE(IBEND,+1)
. D CHNGEVEN(IBCLIEN,IBDFN,IBNEWDT)
. D CLKSTAMP(IBCLIEN,IBDFN)
. L -^IBA(351.81,0)
;
Q
;if there are free days then:
; returns 1
;otherwise:
; returns 0
EXEMPT21(IBCLIEN) ;
Q $P($G(^IBA(351.81,IBCLIEN,0)),"^",6)>0
;returns a new expiration date
;which is = the same day next year - 1 day
;example : for 3000401 it is 3010331
GETEXPDT(IBDATE) ;
N IBY,IBMD
S IBMD=$E(IBDATE,4,7)
S IBY=$E(IBDATE,1,3)
I IBMD="0229" S IBMD="0228"
S IBY=IBY+1
Q $$CHNGDATE(+(IBY_IBMD),-1)
;sets #350.81 fields 4.03 USER LAST UPDATING and 4.04 DATE LAST UPDATED
;Note: use outside LOCK
CLKSTAMP(IBIENCL,IBDFN1) ;
N IBIENS,IBFDA,IBD,IBERR
S IBIENS=IBIENCL_","
S IBFDA(351.81,IBIENS,4.03)=+$G(DUZ)
D NOW^%DTC S IBD=%
S IBFDA(351.81,IBIENS,4.04)=IBD
D FILE^DIE("","IBFDA","IBERR")
I $D(IBERR) D
. D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks","stamp error:"_$G(IBERR("DIERR",1,"TEXT",1)))
Q
;resets fields .03 (CLOCK BEGIN DATE) and .04 (CLOCK EXPIRATION DATE) of LTC clock file
;INPUT:
;IBIENCL - ien of #351.81
;IBDATE - date in FM format
;Note: use outside LOCK
RESET21(IBIENCL,IBDATE,IBDFN1) ;
N IBIENS,IBFDA,IBERR
S IBIENS=IBIENCL_"," ; "D0,"
S IBFDA(351.81,IBIENS,.03)=IBDATE ;begin date (file#,IENS,field#)
S IBFDA(351.81,IBIENS,.04)=$$GETEXPDT(IBDATE) ;expiration date (file#,IENS,field#)
D FILE^DIE("","IBFDA","IBERR")
I $D(IBERR) D
. D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks",$G(IBERR("DIERR",1,"TEXT",1)))
Q
;Adds a new exempt day to multiple in #351.81
;Set EXEMPT DAYS REMAINING to appropriate value
;INPUT:
;IBCLIEN - ien in file #351.81
;DATE - new exempt date
;Note: use outside LOCK
ADDEXDAY(IBIENCL,IBDATE,IBDFN1) ;
N IBIENS,IBFDA,IBDAY,IBERR,IBSSI
S IBDAY=+$P($G(^IBA(351.81,IBIENCL,1,0)),"^",4)
Q:IBDAY=21
S IBDAY=IBDAY+1
;-add day
S IBIENS="+1,"_IBIENCL_"," ; "+1,D0,"
S IBFDA(351.811,IBIENS,.01)=IBDAY ;(file#,IENS,field#)
S IBFDA(351.811,IBIENS,.02)=IBDATE ;(file#,IENS,field#)
D UPDATE^DIE("","IBFDA","IBSSI","IBERR")
I $D(IBERR) D
. D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks",$G(IBERR("DIERR",1,"TEXT",1)))
;-decrease DAYS REMAINING
S IBIENS=IBIENCL_"," ; "D0,"
S IBFDA(351.81,IBIENS,.06)=21-IBDAY ;Expiration date (file#,IENS,field#)
D FILE^DIE("","IBFDA","IBERR")
I $D(IBERR) D
. D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks",$G(IBERR("DIERR",1,"TEXT",1)))
Q
;check for 21 days errors
;run once before start to process all days of the month for the patient
;check correct number of days
;IBIEN- ien of #351.81
;if no days returns 0
;if an error then files into ERRLOG and returns -1 or -2
;if OK returns number of exempted days
CHKDSERR(IBIENCL,IBDFN1) ;
N IBDAT,IBDS
S IBDAT=$G(^IBA(351.81,IBIENCL,1,0))
Q:IBDAT="" 0
S IBDS=$P($G(^IBA(351.81,IBIENCL,0)),"^",6)
I +$P(IBDAT,"^",3)'=+$P(IBDAT,"^",4) D Q -1
. D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks","total number of entries and last EXEMPT DAY NUMBER are not equal in #351.811")
I IBDS'=(21-$P(IBDAT,"^",3)) D Q -2
. D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks","DAYS REMAINING'=21-last EXEMPT DAY NUMBER")
I IBDS'=(21-$P(IBDAT,"^",4)) D Q -3
. D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks","DAYS REMAINING'=21-total number of #351.811 entries")
Q +$P(IBDAT,"^",4)
;closes entry in file #351.81
; set STATUS = CLOSED
;Note: use outside LOCK
CLOSECLK(IBIENCL,IBDFN1) ;
D CHNGSTAT(IBIENCL,IBDFN1,2)
Q
;Cancels clock entry
; set STATUS = CANCEL
;Note: use outside LOCK
CANCCLCK(IBIENCL,IBDFN1) ;
D CHNGSTAT(IBIENCL,IBDFN1,3)
Q
;resets CURRENT EVENTS DATE field
;INPUT:
;IBIENCL - ien of #351.81
;IBDFN1 - dfn of the patient
;IBDATE - new date or ""
;Note: use outside LOCK
CHNGEVEN(IBIENCL,IBDFN1,IBDATE) ;
N IBIENS,IBFDA,IBERR
S IBIENS=IBIENCL_"," ; "D0,"
S IBFDA(351.81,IBIENS,.07)=IBDATE ;status (file#,IENS,field#)
D FILE^DIE("","IBFDA","IBERR")
I $D(IBERR) D
. D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks","change current event="_$G(IBDATE)_" "_$G(IBERR("DIERR",1,"TEXT",1)))
Q
;resets STATUS field
;INPUT:
;IBIENCL - ien of #351.81
;Note: use outside LOCK
CHNGSTAT(IBIENCL,IBDFN1,IBNEWST) ;
N IBIENS,IBFDA,IBERR
S IBIENS=IBIENCL_"," ; "D0,"
S IBFDA(351.81,IBIENS,.05)=IBNEWST ;status (file#,IENS,field#)
D FILE^DIE("","IBFDA","IBERR")
I $D(IBERR) D
. D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"Clocks","change status="_$G(IBNEWST)_" "_$G(IBERR("DIERR",1,"TEXT",1)))
Q
;creates a new entry in file #351.81
;sets adds (#.01),(#.02),(#.03),(#.05),(#4.01),(#4.02)
;DOES NOT set EXPIRATION date (use RESET21)
;returns new ien in file #351.81
NEWCLK(IBDFN,IBDT) ;
N IBIEN
I '$D(DUZ) N DUZ S DUZ=0
S:'$D(U) U="^"
S IBIEN=$$ADDCL^IBAECU(IBDFN,IBDT)
Q:IBIEN<0 0 ;if was not created
Q IBIEN
;run once to fix everything before start to process all days of the month for the patient
;fix 21 days clock if CHKDSERR returns IBERCOD<0
;IBIEN- ien of #351.81
;Note: use outside LOCK
FIX21CLK(IBIEN) ;
N IBV1,IBV2,IBARR,IBDFN1,IBDEL,IBIENS,IBERR,IBFDA,IBDATA,IBBEG,IBEXP
S (IBV1,IBARR,IBDEL)=0
S IBDATA=$G(^IBA(351.81,IBIEN,0))
S IBDFN1=+$P(IBDATA,"^",2)
S IBBEG=+$P(IBDATA,"^",3)
S IBEXP=+$P(IBDATA,"^",4)
I +IBEXP=0 D
. S IBIENS=IBIEN_"," ; "D0,"
. S IBFDA(351.81,IBIENS,.04)=$$GETEXPDT(IBBEG) ;expiration date
. D FILE^DIE("","IBFDA","IBERR")
. I $D(IBERR) D
. . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIEN),"Clocks",$G(IBERR("DIERR",1,"TEXT",1)))
. S IBEXP=+$P($G(^IBA(351.81,IBIEN,0)),"^",4)
;
Q:+IBDFN1=0
F S IBV1=$O(^IBA(351.81,IBIEN,1,IBV1)) Q:+IBV1=0 D
. S IBV2=+$P($G(^IBA(351.81,IBIEN,1,IBV1,0)),"^",2)
. I IBV2<IBBEG!(IBV2>IBEXP) D
. . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIEN),"Clocks","Exempt day is out of clock range")
. S IBARR(+$P($G(^IBA(351.81,IBIEN,1,IBV1,0)),"^",2))=""
. S IBDEL(IBV1)=""
;- DAYS REMAINING
S IBIENS=IBIEN_"," ; "D0,"
S IBFDA(351.81,IBIENS,.06)=21 ; (file#,IENS,field#)
D FILE^DIE("","IBFDA","IBERR")
I $D(IBERR) D
. D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIEN),"Clocks",$G(IBERR("DIERR",1,"TEXT",1)))
S IBV1=0
F S IBV1=$O(IBDEL(IBV1)) Q:+IBV1=0 D
. D DELEXDAY(IBIEN,IBV1)
S IBV1=0
F S IBV1=$O(IBARR(IBV1)) Q:+IBV1=0 D
. D ADDEXDAY(IBIEN,IBV1,IBDFN1)
Q
;Delete exempt day from multiple
;INPUT:
;IBIEN - ien in file #351.81
;IBN - ien of exempt date entry
;Note: use outside LOCK
DELEXDAY(IBIEN,IBN) ;
N IBIENS,IBFDA
S IBIENS=IBN_","_IBIEN_","
S IBFDA(351.811,IBIENS,.01)="@"
D FILE^DIE("","IBFDA")
Q
;
FNDOPEN(DFN) ; find last open LTC clock for the patient IB*2.0*728
;
; DFN - patient DFN
;
; returns IEN of the open clock (file 351.81), or 0 if none was found
;
N IBCL,IBFOUND,IBX
S IBFOUND=0,IBX=9999999 F S IBX=$O(^IBA(351.81,"AE",DFN,IBX),-1) Q:'IBX!IBFOUND D
.S IBCL=0 F S IBCL=$O(^IBA(351.81,"AE",DFN,IBX,IBCL)) Q:'IBCL!IBFOUND I +$P(^IBA(351.81,IBCL,0),U,5)=1 S IBFOUND=IBCL
.Q
Q IBFOUND
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAECU4 8988 printed Dec 13, 2024@02:06:10 Page 2
IBAECU4 ;WOIFO/SS - LTC PHASE 2 UTILITIES ; 20-FEB-02
+1 ;;2.0;INTEGRATED BILLING;**171,176,728**;21-MAR-94;Build 14
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;** LTC Clock related utilities **
+4 ;Makes FM date from any date of month or YEAR_MONTH and Day #
MKDATE(IBYM,IBD) ;
+1 QUIT $EXTRACT(IBYM,1,5)_$SELECT(IBD<10:"0"_IBD,1:IBD)
+2 ;substracts (CHNG<0) or adds (CHNG>0) days to date
+3 ;DATE - date in FM format
CHNGDATE(DATE,CHNG) ;
+1 NEW X,X1,X2
+2 SET X1=DATE
SET X2=CHNG
DO C^%DTC
+3 QUIT X
+4 ;adjusts clocks
+5 ; "C" - cancel it
+6 ; "P" - 1) mark patient as "processed" i.e. we should
+7 ; set CURRENT EVENTS DATE=""
+8 ; or to 1st day of the next month if the patient is not disharged yet
+9 ; 2)adjust 180 days clocks
+10 ;.IBCLKADJ - array with info regarding clock adjustment
+11 ;IBCLKIEN - ien of file 351.81
+12 ;IBDFN - dfn of the patient
+13 ;IBINPLD - returned value of $$ISINPAT^IBAECU2 for the last date of the month
+14 ; if "^" - no admission for the last day of the
+15 ; processed month, set CURRENT EVENTS DATE=""
+16 ; if "number^" then we have inpatient LTC on the last day,
+17 ; set CURRENT EVENTS DATE=1st day of the following month
+18 ;IBEND the last date of the month
CLCKADJ(IBCLKADJ,IBCLIEN,IBDFN,IBINPLD,IBEND) ;
+1 NEW IBNEWDT
+2 ;check if it is the 1st MJ then do not cancel clock and do not clear CURRENT EVENTS field
+3 IF $GET(IBMJ1ST)="MJ1ST"
if IBCLKADJ="C"
QUIT
if +IBINPLD=0
QUIT
+4 SET IBNEWDT=""
+5 ;"C": cancel clock
+6 IF IBCLKADJ="C"
Begin DoDot:1
+7 ;quit
LOCK +^IBA(351.81,0):10
IF '$TEST
Begin DoDot:2
+8 DO ERRLOG^IBAECU5(+$GET(IBDFN),+$GET(IBCLIEN),"Clocks","Lock error: not cancelled")
End DoDot:2
QUIT
+9 ;cancel clock
DO CANCCLCK(IBCLIEN,IBDFN)
+10 DO CLKSTAMP(IBCLIEN,IBDFN)
+11 LOCK -^IBA(351.81,0)
End DoDot:1
QUIT
+12 ;"P": mark that the patient has been processed succesfully
+13 IF IBCLKADJ="P"
Begin DoDot:1
+14 ;quit
LOCK +^IBA(351.81,0):10
IF '$TEST
Begin DoDot:2
+15 DO ERRLOG^IBAECU5(+$GET(IBDFN),+$GET(IBCLIEN),"Clocks","Lock error: no current event change")
End DoDot:2
QUIT
+16 IF +IBINPLD>0
SET IBNEWDT=$$CHNGDATE(IBEND,+1)
+17 DO CHNGEVEN(IBCLIEN,IBDFN,IBNEWDT)
+18 DO CLKSTAMP(IBCLIEN,IBDFN)
+19 LOCK -^IBA(351.81,0)
End DoDot:1
QUIT
+20 ;
+21 QUIT
+22 ;if there are free days then:
+23 ; returns 1
+24 ;otherwise:
+25 ; returns 0
EXEMPT21(IBCLIEN) ;
+1 QUIT $PIECE($GET(^IBA(351.81,IBCLIEN,0)),"^",6)>0
+2 ;returns a new expiration date
+3 ;which is = the same day next year - 1 day
+4 ;example : for 3000401 it is 3010331
GETEXPDT(IBDATE) ;
+1 NEW IBY,IBMD
+2 SET IBMD=$EXTRACT(IBDATE,4,7)
+3 SET IBY=$EXTRACT(IBDATE,1,3)
+4 IF IBMD="0229"
SET IBMD="0228"
+5 SET IBY=IBY+1
+6 QUIT $$CHNGDATE(+(IBY_IBMD),-1)
+7 ;sets #350.81 fields 4.03 USER LAST UPDATING and 4.04 DATE LAST UPDATED
+8 ;Note: use outside LOCK
CLKSTAMP(IBIENCL,IBDFN1) ;
+1 NEW IBIENS,IBFDA,IBD,IBERR
+2 SET IBIENS=IBIENCL_","
+3 SET IBFDA(351.81,IBIENS,4.03)=+$GET(DUZ)
+4 DO NOW^%DTC
SET IBD=%
+5 SET IBFDA(351.81,IBIENS,4.04)=IBD
+6 DO FILE^DIE("","IBFDA","IBERR")
+7 IF $DATA(IBERR)
Begin DoDot:1
+8 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBIENCL),"Clocks","stamp error:"_$GET(IBERR("DIERR",1,"TEXT",1)))
End DoDot:1
+9 QUIT
+10 ;resets fields .03 (CLOCK BEGIN DATE) and .04 (CLOCK EXPIRATION DATE) of LTC clock file
+11 ;INPUT:
+12 ;IBIENCL - ien of #351.81
+13 ;IBDATE - date in FM format
+14 ;Note: use outside LOCK
RESET21(IBIENCL,IBDATE,IBDFN1) ;
+1 NEW IBIENS,IBFDA,IBERR
+2 ; "D0,"
SET IBIENS=IBIENCL_","
+3 ;begin date (file#,IENS,field#)
SET IBFDA(351.81,IBIENS,.03)=IBDATE
+4 ;expiration date (file#,IENS,field#)
SET IBFDA(351.81,IBIENS,.04)=$$GETEXPDT(IBDATE)
+5 DO FILE^DIE("","IBFDA","IBERR")
+6 IF $DATA(IBERR)
Begin DoDot:1
+7 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBIENCL),"Clocks",$GET(IBERR("DIERR",1,"TEXT",1)))
End DoDot:1
+8 QUIT
+9 ;Adds a new exempt day to multiple in #351.81
+10 ;Set EXEMPT DAYS REMAINING to appropriate value
+11 ;INPUT:
+12 ;IBCLIEN - ien in file #351.81
+13 ;DATE - new exempt date
+14 ;Note: use outside LOCK
ADDEXDAY(IBIENCL,IBDATE,IBDFN1) ;
+1 NEW IBIENS,IBFDA,IBDAY,IBERR,IBSSI
+2 SET IBDAY=+$PIECE($GET(^IBA(351.81,IBIENCL,1,0)),"^",4)
+3 if IBDAY=21
QUIT
+4 SET IBDAY=IBDAY+1
+5 ;-add day
+6 ; "+1,D0,"
SET IBIENS="+1,"_IBIENCL_","
+7 ;(file#,IENS,field#)
SET IBFDA(351.811,IBIENS,.01)=IBDAY
+8 ;(file#,IENS,field#)
SET IBFDA(351.811,IBIENS,.02)=IBDATE
+9 DO UPDATE^DIE("","IBFDA","IBSSI","IBERR")
+10 IF $DATA(IBERR)
Begin DoDot:1
+11 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBIENCL),"Clocks",$GET(IBERR("DIERR",1,"TEXT",1)))
End DoDot:1
+12 ;-decrease DAYS REMAINING
+13 ; "D0,"
SET IBIENS=IBIENCL_","
+14 ;Expiration date (file#,IENS,field#)
SET IBFDA(351.81,IBIENS,.06)=21-IBDAY
+15 DO FILE^DIE("","IBFDA","IBERR")
+16 IF $DATA(IBERR)
Begin DoDot:1
+17 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBIENCL),"Clocks",$GET(IBERR("DIERR",1,"TEXT",1)))
End DoDot:1
+18 QUIT
+19 ;check for 21 days errors
+20 ;run once before start to process all days of the month for the patient
+21 ;check correct number of days
+22 ;IBIEN- ien of #351.81
+23 ;if no days returns 0
+24 ;if an error then files into ERRLOG and returns -1 or -2
+25 ;if OK returns number of exempted days
CHKDSERR(IBIENCL,IBDFN1) ;
+1 NEW IBDAT,IBDS
+2 SET IBDAT=$GET(^IBA(351.81,IBIENCL,1,0))
+3 if IBDAT=""
QUIT 0
+4 SET IBDS=$PIECE($GET(^IBA(351.81,IBIENCL,0)),"^",6)
+5 IF +$PIECE(IBDAT,"^",3)'=+$PIECE(IBDAT,"^",4)
Begin DoDot:1
+6 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBIENCL),"Clocks","total number of entries and last EXEMPT DAY NUMBER are not equal in #351.811")
End DoDot:1
QUIT -1
+7 IF IBDS'=(21-$PIECE(IBDAT,"^",3))
Begin DoDot:1
+8 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBIENCL),"Clocks","DAYS REMAINING'=21-last EXEMPT DAY NUMBER")
End DoDot:1
QUIT -2
+9 IF IBDS'=(21-$PIECE(IBDAT,"^",4))
Begin DoDot:1
+10 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBIENCL),"Clocks","DAYS REMAINING'=21-total number of #351.811 entries")
End DoDot:1
QUIT -3
+11 QUIT +$PIECE(IBDAT,"^",4)
+12 ;closes entry in file #351.81
+13 ; set STATUS = CLOSED
+14 ;Note: use outside LOCK
CLOSECLK(IBIENCL,IBDFN1) ;
+1 DO CHNGSTAT(IBIENCL,IBDFN1,2)
+2 QUIT
+3 ;Cancels clock entry
+4 ; set STATUS = CANCEL
+5 ;Note: use outside LOCK
CANCCLCK(IBIENCL,IBDFN1) ;
+1 DO CHNGSTAT(IBIENCL,IBDFN1,3)
+2 QUIT
+3 ;resets CURRENT EVENTS DATE field
+4 ;INPUT:
+5 ;IBIENCL - ien of #351.81
+6 ;IBDFN1 - dfn of the patient
+7 ;IBDATE - new date or ""
+8 ;Note: use outside LOCK
CHNGEVEN(IBIENCL,IBDFN1,IBDATE) ;
+1 NEW IBIENS,IBFDA,IBERR
+2 ; "D0,"
SET IBIENS=IBIENCL_","
+3 ;status (file#,IENS,field#)
SET IBFDA(351.81,IBIENS,.07)=IBDATE
+4 DO FILE^DIE("","IBFDA","IBERR")
+5 IF $DATA(IBERR)
Begin DoDot:1
+6 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBIENCL),"Clocks","change current event="_$GET(IBDATE)_" "_$GET(IBERR("DIERR",1,"TEXT",1)))
End DoDot:1
+7 QUIT
+8 ;resets STATUS field
+9 ;INPUT:
+10 ;IBIENCL - ien of #351.81
+11 ;Note: use outside LOCK
CHNGSTAT(IBIENCL,IBDFN1,IBNEWST) ;
+1 NEW IBIENS,IBFDA,IBERR
+2 ; "D0,"
SET IBIENS=IBIENCL_","
+3 ;status (file#,IENS,field#)
SET IBFDA(351.81,IBIENS,.05)=IBNEWST
+4 DO FILE^DIE("","IBFDA","IBERR")
+5 IF $DATA(IBERR)
Begin DoDot:1
+6 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBIENCL),"Clocks","change status="_$GET(IBNEWST)_" "_$GET(IBERR("DIERR",1,"TEXT",1)))
End DoDot:1
+7 QUIT
+8 ;creates a new entry in file #351.81
+9 ;sets adds (#.01),(#.02),(#.03),(#.05),(#4.01),(#4.02)
+10 ;DOES NOT set EXPIRATION date (use RESET21)
+11 ;returns new ien in file #351.81
NEWCLK(IBDFN,IBDT) ;
+1 NEW IBIEN
+2 IF '$DATA(DUZ)
NEW DUZ
SET DUZ=0
+3 if '$DATA(U)
SET U="^"
+4 SET IBIEN=$$ADDCL^IBAECU(IBDFN,IBDT)
+5 ;if was not created
if IBIEN<0
QUIT 0
+6 QUIT IBIEN
+7 ;run once to fix everything before start to process all days of the month for the patient
+8 ;fix 21 days clock if CHKDSERR returns IBERCOD<0
+9 ;IBIEN- ien of #351.81
+10 ;Note: use outside LOCK
FIX21CLK(IBIEN) ;
+1 NEW IBV1,IBV2,IBARR,IBDFN1,IBDEL,IBIENS,IBERR,IBFDA,IBDATA,IBBEG,IBEXP
+2 SET (IBV1,IBARR,IBDEL)=0
+3 SET IBDATA=$GET(^IBA(351.81,IBIEN,0))
+4 SET IBDFN1=+$PIECE(IBDATA,"^",2)
+5 SET IBBEG=+$PIECE(IBDATA,"^",3)
+6 SET IBEXP=+$PIECE(IBDATA,"^",4)
+7 IF +IBEXP=0
Begin DoDot:1
+8 ; "D0,"
SET IBIENS=IBIEN_","
+9 ;expiration date
SET IBFDA(351.81,IBIENS,.04)=$$GETEXPDT(IBBEG)
+10 DO FILE^DIE("","IBFDA","IBERR")
+11 IF $DATA(IBERR)
Begin DoDot:2
+12 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBIEN),"Clocks",$GET(IBERR("DIERR",1,"TEXT",1)))
End DoDot:2
+13 SET IBEXP=+$PIECE($GET(^IBA(351.81,IBIEN,0)),"^",4)
End DoDot:1
+14 ;
+15 if +IBDFN1=0
QUIT
+16 FOR
SET IBV1=$ORDER(^IBA(351.81,IBIEN,1,IBV1))
if +IBV1=0
QUIT
Begin DoDot:1
+17 SET IBV2=+$PIECE($GET(^IBA(351.81,IBIEN,1,IBV1,0)),"^",2)
+18 IF IBV2<IBBEG!(IBV2>IBEXP)
Begin DoDot:2
+19 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBIEN),"Clocks","Exempt day is out of clock range")
End DoDot:2
+20 SET IBARR(+$PIECE($GET(^IBA(351.81,IBIEN,1,IBV1,0)),"^",2))=""
+21 SET IBDEL(IBV1)=""
End DoDot:1
+22 ;- DAYS REMAINING
+23 ; "D0,"
SET IBIENS=IBIEN_","
+24 ; (file#,IENS,field#)
SET IBFDA(351.81,IBIENS,.06)=21
+25 DO FILE^DIE("","IBFDA","IBERR")
+26 IF $DATA(IBERR)
Begin DoDot:1
+27 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBIEN),"Clocks",$GET(IBERR("DIERR",1,"TEXT",1)))
End DoDot:1
+28 SET IBV1=0
+29 FOR
SET IBV1=$ORDER(IBDEL(IBV1))
if +IBV1=0
QUIT
Begin DoDot:1
+30 DO DELEXDAY(IBIEN,IBV1)
End DoDot:1
+31 SET IBV1=0
+32 FOR
SET IBV1=$ORDER(IBARR(IBV1))
if +IBV1=0
QUIT
Begin DoDot:1
+33 DO ADDEXDAY(IBIEN,IBV1,IBDFN1)
End DoDot:1
+34 QUIT
+35 ;Delete exempt day from multiple
+36 ;INPUT:
+37 ;IBIEN - ien in file #351.81
+38 ;IBN - ien of exempt date entry
+39 ;Note: use outside LOCK
DELEXDAY(IBIEN,IBN) ;
+1 NEW IBIENS,IBFDA
+2 SET IBIENS=IBN_","_IBIEN_","
+3 SET IBFDA(351.811,IBIENS,.01)="@"
+4 DO FILE^DIE("","IBFDA")
+5 QUIT
+6 ;
FNDOPEN(DFN) ; find last open LTC clock for the patient IB*2.0*728
+1 ;
+2 ; DFN - patient DFN
+3 ;
+4 ; returns IEN of the open clock (file 351.81), or 0 if none was found
+5 ;
+6 NEW IBCL,IBFOUND,IBX
+7 SET IBFOUND=0
SET IBX=9999999
FOR
SET IBX=$ORDER(^IBA(351.81,"AE",DFN,IBX),-1)
if 'IBX!IBFOUND
QUIT
Begin DoDot:1
+8 SET IBCL=0
FOR
SET IBCL=$ORDER(^IBA(351.81,"AE",DFN,IBX,IBCL))
if 'IBCL!IBFOUND
QUIT
IF +$PIECE(^IBA(351.81,IBCL,0),U,5)=1
SET IBFOUND=IBCL
+9 QUIT
End DoDot:1
+10 QUIT IBFOUND
