Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBAECU4

IBAECU4.m

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