- 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 Feb 18, 2025@23:32:35 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