- IBAECN1 ;WOIFO/SS-LTC PHASE 2 NIGHTLY JOB ; 20-FEB-02
- ;;2.0;INTEGRATED BILLING;**176,188**;21-MAR-94
- ;; Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- BILDATE() ;billing start date for Long Term Care Billing
- ; Means Test for LTC care billing stopped on JUNE 17,2002 /see
- ; STDATE^IBAECU1()/ . LTC billing for LTC care must start on
- ; JULY 26,2002. There is no billing for LTC care in period
- ; between JUNE 17,2002 and JULY 26,2002. That means LTC clock
- ; will start on JULY 5,2002 (because of 21 "free" days)
- Q 3020705 ;
- ;
- NJ ;LTC Nightly job
- N X I $D(^%ZOSF("TRAP")) S X="ERR^IBAECN1",@^("TRAP")
- N IBPRMNTH S IBPRMNTH=$$PREVMNTH^IBAECM1() ;last day of previous month
- Q:$$BILDATE()>IBPRMNTH
- ;
- N IBLSTMJ S IBLSTMJ=$$LASTMJ^IBAECU()
- ;run code for the 1st monthly job
- I IBLSTMJ=0 D MJ1ST^IBAECM3 Q
- ;if was run & successfully completed this month- quit
- Q:IBLSTMJ'<($E($$TODAY(),1,5)_"01")
- ;------- local arrays
- ;IBMDS1(0)-1st,IBMDS1(1) last day in the month,
- ;IBMDS1(2)-year_month, IBMDS1 - number of days
- N IBMDS1 S IBMDS1=""
- ;dates,days for processing month which is normally
- ; previous month because MJ runs 1stday of the month
- S IBMDS1(1)=IBPRMNTH,IBMDS1(2)=$E(IBMDS1(1),1,5)
- S IBMDS1(0)=IBMDS1(2)_"01",IBMDS1=$E(IBMDS1(1),6,7)
- D MJT^IBAECM1
- D RESET
- Q
- ;
- ERR ;Error trap for NJ
- N XMSUB,XMTEXT,XMY,XMZ,XMMG,IBL,IBT,XMDUZ,IBPAT,IBTODAY
- N XMGROUP S XMGROUP=$$GET1^DIQ(350.9,"1,",.09)
- Q:XMGROUP=""
- S XMGROUP="G."_XMGROUP
- S IBPAT="Unknown",IBTODAY=""
- N Y D NOW^%DTC S Y=% X ^DD("DD") S IBTODAY=Y
- I +$G(DFN)>0 D
- . N VADM,VA,VAERR
- . D DEM^VADPT
- . S IBPAT=$G(VADM(1))_", SSN: "_$P($G(VADM(2)),"^",2)
- S:IBPAT=", SSN: " IBPAT="Unknown"
- S XMSUB="LTC Monthly Job Failure",XMY(XMGROUP)=""
- S XMTEXT="IBT(",XMDUZ="INTEGRATED BILLING PACKAGE"
- S IBT(1,0)="**********************************************"
- S IBT(2,0)="LTC Monthly Job crashed on "_IBTODAY
- S IBT(3,0)="when the system was processing the following patient : "
- S IBT(4,0)=" "_IBPAT
- S IBT(5,0)="Please verify data for the patient, fix findings"
- S IBT(6,0)="and then:"
- S IBT(7,0)="- if today is the last day of the month then you"
- S IBT(8,0)=" need to run NJ^IBAECN1 today manually from"
- S IBT(9,0)=" programmer mode."
- S IBT(10,0)="- otherwise let the system run the NJ^IBAECN1"
- S IBT(11,0)=" automatically after midnight."
- S IBT(12,0)=""
- S IBT(13,0)="In both cases, please, check patient's charges and"
- S IBT(14,0)="your e-mail again."
- D ^XMD
- Q
- ;
- ;checks if the most recent treating specialty of the admission
- ;is related to LTC?
- ;invoked from PROC^IBAMTC Exmpl:
- ; I $$ISLTCADM(DFN,IBA)
- ;to create entries in 351.81 if necessary
- ;Input:
- ;IBDFN - patient's ien in file (#2)
- ;IB405 - ien of admission (#405)
- ;Output:
- ;returns 0 if the specialty for non-LTC care
- ;otherwise - returns 1
- ;
- ISLTCADM(IBDFN,IB405) ;
- ;1) treat all LTC as Means Test if the legislation is not effective yet
- I $$YESTRDAY()<$$BILDATE() Q 0
- N IBSPEC,IBTS
- S IBTS="M"
- ;2) determine treating specialty (TS)
- S IBSPEC=$$LASTTS(IBDFN,IB405) ;most recent TS (pointer #42.4)
- I IBSPEC>0 S IBTS=$P($$TREATSP^IBAECU2(IBSPEC),"^",1) ;is it LTC or not?
- I IBSPEC'>0 S IBTS="M" ;treat unknown as Means Test
- I IBTS="L" D Q 1 ;if TS is LTC
- . I $$CLOCK^IBAECU(IBDFN,$$YESTRDAY())
- Q 0
- ;finds the most recent parent entry in #350 related to admission
- ;Input:
- ;IBDFN - patient's dfn
- ;IBDT - the date to seek from (today)
- ;IBADM - admission we are seeking for
- ;IBSTAT = status we are seeking for
- ;output:
- ;returns ien_of_350^IB_action_type
- ;or "0^" if not found
- FIND350(IBDFN,IBDATE,IBADM,IBSTAT) ;
- N IB350,IBDT,IBINF,IBFL
- S IBFL=0,IBINF=""
- S IBDT=-IBDATE F S IBDT=$O(^IB("AFDT",IBDFN,IBDT)) Q:IBFL!(+IBDT=0) D
- . S IB350=0 F S IB350=$O(^IB("AFDT",IBDFN,IBDT,IB350)) Q:+IB350=0 D
- . . Q:'$D(^IB("AC",IBSTAT,IB350))
- . . S IBINF=$G(^IB(IB350,0))
- . . Q:IB350'=$P(IBINF,"^",16) ;non parent
- . . Q:$P($P(IBINF,"^",4),":",1)'="405" ;non inpatient
- . . S:$P($P(IBINF,"^",4),":",2)=IBADM IBFL=IB350
- Q IBFL_"^"_$P($G(IBINF),"^",3)
- ;
- ;edit #350 event entry
- ;IBIENCL - ien of #350
- ;IBLSTDT = DATE LAST BILLED
- ;IBADM - ien in #405
- STAT350(IBIENCL,IBLSTDT,IBADM) ;
- N IBIENS,IBFDA,IBERR,IBDFN1
- S IBDFN1=$P($G(^IB(IBIENCL,0)),"^",2)
- Q:+IBDFN1=0
- S IBIENS=IBIENCL_"," ; "D0,"
- S IBFDA(350,IBIENS,13)=+$G(DUZ)
- S:'$P($G(^IB(IBIENCL,0)),"^",17) IBFDA(350,IBIENS,.17)=(+$G(^DGPM(IBADM,0)))\1
- S IBFDA(350,IBIENS,.18)=(+$G(IBLSTDT))\1
- D NOW^%DTC S IBD=%
- S IBFDA(350,IBIENS,14)=IBD
- D FILE^DIE("","IBFDA","IBERR")
- I $D(IBERR) D
- . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"BILLING ACTION:","closing parent entry"_$G(IBERR("DIERR",1,"TEXT",1)))
- Q
- ;------
- ;create a new inpatient parent event entry in #350
- ;Input:
- ;DFN - patient's ien #2
- ;IBADMIEN - admission ien #405
- ;IBEVDT - event date (piece 17) for parent entry must be an admission date,
- ;IBNH:
- ; 1 - for 56 (#350.1) NHCU ADMISSION
- ; 93 - for 93 (#350.1) LTC ADMISSION
- ; 0 - all other events
- ;Returns:
- ;New ien of #350 Or 0 if not created
- CREV350(DFN,IBADMIEN,IBEVDT,IBNH) ;
- Q:IBEVDT=0 0
- N IBEVDA,IBSL,IBSERV
- S IBEVDA=0
- D SERV^IBAUTL2
- I '$D(IBSITE)!('$D(IBFAC)) D SITE^IBAUTL
- S IBSL="405:"_IBADMIEN
- ;if LTC ADMISSION set IBNHLTC
- I IBNH=93 N IBNHLTC S IBNHLTC=93
- D EVADD^IBAUTL3
- Q IBEVDA
- ;
- ;Find original admission ien, considering ASIH movements
- ;Input: ien of 405 that can be "child", for example
- ; we have ien of Nursing Home admission
- ; then patient moved to ASIH to hospital
- ; if IBA is ASIH hospital admission ien then call will return
- ; "original" Nursing Home admission's ien
- ;Output: ien of 405 of "original" admission
- ORIGADM(IBA) ;
- N X,Y,Z S Z=IBA
- F S X=$G(^DGPM(Z,0)),Y=$P(X,"^",21) Q:Y="" S Z=+$P($G(^DGPM(Y,0)),"^",14)
- Q +Z
- ;
- ;most recent treating specialty
- ;input:
- ;IBDFN - patient ien
- ;IB405ADM - admission's #405 ien
- ;output:
- ;returns ien of SPECIALTY FILE (#42.4)
- LASTTS(IBDFN,IB405ADM) ;
- N IBDT6,IBSPEC
- S IBDT6=0
- S IBDT6=+$O(^DGPM("ATS",IBDFN,IB405ADM,IBDT6))
- Q:+IBDT6=0 -1 ;error
- S IBSPEC=$O(^DGPM("ATS",IBDFN,IB405ADM,IBDT6,0))
- Q:+IBSPEC=0 -1 ;error
- ;convert fac spec (45.7) -> treat spec (#42.4)
- S IBSPEC=+$P($G(^DIC(45.7,IBSPEC,0)),"^",2)
- Q:+IBSPEC=0 -1
- Q IBSPEC
- ;returns today date
- TODAY() ;
- N X
- D NOW^%DTC
- Q X
- ;returns yesterday date
- YESTRDAY() ;
- N X1,X2,X
- S X1=$$TODAY()
- S X2=-1
- D C^%DTC
- Q X
- ;returns 1 if the most recent treating specialty for this billable
- ;event and for this date was LTC
- ;DFN -patient ien
- ;IBEVDA - ien of event in #350
- ;IBDT - date
- ASIHORG(DFN,IBEVDA,IBDT) ;
- N IB405 S IB405=+$P($P($G(^IB(+IBEVDA,0)),"^",4),":",2)
- Q:IB405=0 0
- Q $$ISLTC4DT(DFN,IB405,IBDT_.2359)
- ;
- ;returns 1 if the most recent treating specialty for the admission
- ;and the date was LTC specialty
- ;otherwise returns 0 or -1
- ;DFN -patient ien
- ;IB405ADM - ien of #405
- ;IBDT - date
- ISLTC4DT(IBDFN,IB405ADM,IBDT) ;
- N IBDT6,IBSPEC,IBTS
- S IBDT6=9999999.9999999-IBDT
- S IBDT6=+$O(^DGPM("ATS",IBDFN,IB405ADM,IBDT6))
- Q:+IBDT6=0 -1 ;error
- S IBSPEC=$O(^DGPM("ATS",IBDFN,IB405ADM,IBDT6,0))
- Q:+IBSPEC=0 -1 ;error
- ;convert fac spec (45.7) -> treat spec (#42.4)
- S IBSPEC=+$P($G(^DIC(45.7,IBSPEC,0)),"^",2)
- I IBSPEC>0 S IBTS=$P($$TREATSP^IBAECU2(IBSPEC),"^",1) ;is it LTC or not?
- I IBSPEC'>0 S IBTS="M" ;unknown as Means Test
- I IBTS="L" Q 1 ;if TS is LTC
- Q 0
- ;
- RESET ; this will reset the ^xtmp global
- K ^XTMP("IB1010EC")
- S ^XTMP("IB1010EC",0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^LIST OF PATIENTS ALREADY REPORTED AS MISSING 1010EC INFO"
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAECN1 7754 printed Feb 18, 2025@23:32:27 Page 2
- IBAECN1 ;WOIFO/SS-LTC PHASE 2 NIGHTLY JOB ; 20-FEB-02
- +1 ;;2.0;INTEGRATED BILLING;**176,188**;21-MAR-94
- +2 ;; Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- BILDATE() ;billing start date for Long Term Care Billing
- +1 ; Means Test for LTC care billing stopped on JUNE 17,2002 /see
- +2 ; STDATE^IBAECU1()/ . LTC billing for LTC care must start on
- +3 ; JULY 26,2002. There is no billing for LTC care in period
- +4 ; between JUNE 17,2002 and JULY 26,2002. That means LTC clock
- +5 ; will start on JULY 5,2002 (because of 21 "free" days)
- +6 ;
- QUIT 3020705
- +7 ;
- NJ ;LTC Nightly job
- +1 NEW X
- IF $DATA(^%ZOSF("TRAP"))
- SET X="ERR^IBAECN1"
- SET @^("TRAP")
- +2 ;last day of previous month
- NEW IBPRMNTH
- SET IBPRMNTH=$$PREVMNTH^IBAECM1()
- +3 if $$BILDATE()>IBPRMNTH
- QUIT
- +4 ;
- +5 NEW IBLSTMJ
- SET IBLSTMJ=$$LASTMJ^IBAECU()
- +6 ;run code for the 1st monthly job
- +7 IF IBLSTMJ=0
- DO MJ1ST^IBAECM3
- QUIT
- +8 ;if was run & successfully completed this month- quit
- +9 if IBLSTMJ'<($EXTRACT($$TODAY(),1,5)_"01")
- QUIT
- +10 ;------- local arrays
- +11 ;IBMDS1(0)-1st,IBMDS1(1) last day in the month,
- +12 ;IBMDS1(2)-year_month, IBMDS1 - number of days
- +13 NEW IBMDS1
- SET IBMDS1=""
- +14 ;dates,days for processing month which is normally
- +15 ; previous month because MJ runs 1stday of the month
- +16 SET IBMDS1(1)=IBPRMNTH
- SET IBMDS1(2)=$EXTRACT(IBMDS1(1),1,5)
- +17 SET IBMDS1(0)=IBMDS1(2)_"01"
- SET IBMDS1=$EXTRACT(IBMDS1(1),6,7)
- +18 DO MJT^IBAECM1
- +19 DO RESET
- +20 QUIT
- +21 ;
- ERR ;Error trap for NJ
- +1 NEW XMSUB,XMTEXT,XMY,XMZ,XMMG,IBL,IBT,XMDUZ,IBPAT,IBTODAY
- +2 NEW XMGROUP
- SET XMGROUP=$$GET1^DIQ(350.9,"1,",.09)
- +3 if XMGROUP=""
- QUIT
- +4 SET XMGROUP="G."_XMGROUP
- +5 SET IBPAT="Unknown"
- SET IBTODAY=""
- +6 NEW Y
- DO NOW^%DTC
- SET Y=%
- XECUTE ^DD("DD")
- SET IBTODAY=Y
- +7 IF +$GET(DFN)>0
- Begin DoDot:1
- +8 NEW VADM,VA,VAERR
- +9 DO DEM^VADPT
- +10 SET IBPAT=$GET(VADM(1))_", SSN: "_$PIECE($GET(VADM(2)),"^",2)
- End DoDot:1
- +11 if IBPAT=", SSN
- SET IBPAT="Unknown"
- +12 SET XMSUB="LTC Monthly Job Failure"
- SET XMY(XMGROUP)=""
- +13 SET XMTEXT="IBT("
- SET XMDUZ="INTEGRATED BILLING PACKAGE"
- +14 SET IBT(1,0)="**********************************************"
- +15 SET IBT(2,0)="LTC Monthly Job crashed on "_IBTODAY
- +16 SET IBT(3,0)="when the system was processing the following patient : "
- +17 SET IBT(4,0)=" "_IBPAT
- +18 SET IBT(5,0)="Please verify data for the patient, fix findings"
- +19 SET IBT(6,0)="and then:"
- +20 SET IBT(7,0)="- if today is the last day of the month then you"
- +21 SET IBT(8,0)=" need to run NJ^IBAECN1 today manually from"
- +22 SET IBT(9,0)=" programmer mode."
- +23 SET IBT(10,0)="- otherwise let the system run the NJ^IBAECN1"
- +24 SET IBT(11,0)=" automatically after midnight."
- +25 SET IBT(12,0)=""
- +26 SET IBT(13,0)="In both cases, please, check patient's charges and"
- +27 SET IBT(14,0)="your e-mail again."
- +28 DO ^XMD
- +29 QUIT
- +30 ;
- +31 ;checks if the most recent treating specialty of the admission
- +32 ;is related to LTC?
- +33 ;invoked from PROC^IBAMTC Exmpl:
- +34 ; I $$ISLTCADM(DFN,IBA)
- +35 ;to create entries in 351.81 if necessary
- +36 ;Input:
- +37 ;IBDFN - patient's ien in file (#2)
- +38 ;IB405 - ien of admission (#405)
- +39 ;Output:
- +40 ;returns 0 if the specialty for non-LTC care
- +41 ;otherwise - returns 1
- +42 ;
- ISLTCADM(IBDFN,IB405) ;
- +1 ;1) treat all LTC as Means Test if the legislation is not effective yet
- +2 IF $$YESTRDAY()<$$BILDATE()
- QUIT 0
- +3 NEW IBSPEC,IBTS
- +4 SET IBTS="M"
- +5 ;2) determine treating specialty (TS)
- +6 ;most recent TS (pointer #42.4)
- SET IBSPEC=$$LASTTS(IBDFN,IB405)
- +7 ;is it LTC or not?
- IF IBSPEC>0
- SET IBTS=$PIECE($$TREATSP^IBAECU2(IBSPEC),"^",1)
- +8 ;treat unknown as Means Test
- IF IBSPEC'>0
- SET IBTS="M"
- +9 ;if TS is LTC
- IF IBTS="L"
- Begin DoDot:1
- +10 IF $$CLOCK^IBAECU(IBDFN,$$YESTRDAY())
- End DoDot:1
- QUIT 1
- +11 QUIT 0
- +12 ;finds the most recent parent entry in #350 related to admission
- +13 ;Input:
- +14 ;IBDFN - patient's dfn
- +15 ;IBDT - the date to seek from (today)
- +16 ;IBADM - admission we are seeking for
- +17 ;IBSTAT = status we are seeking for
- +18 ;output:
- +19 ;returns ien_of_350^IB_action_type
- +20 ;or "0^" if not found
- FIND350(IBDFN,IBDATE,IBADM,IBSTAT) ;
- +1 NEW IB350,IBDT,IBINF,IBFL
- +2 SET IBFL=0
- SET IBINF=""
- +3 SET IBDT=-IBDATE
- FOR
- SET IBDT=$ORDER(^IB("AFDT",IBDFN,IBDT))
- if IBFL!(+IBDT=0)
- QUIT
- Begin DoDot:1
- +4 SET IB350=0
- FOR
- SET IB350=$ORDER(^IB("AFDT",IBDFN,IBDT,IB350))
- if +IB350=0
- QUIT
- Begin DoDot:2
- +5 if '$DATA(^IB("AC",IBSTAT,IB350))
- QUIT
- +6 SET IBINF=$GET(^IB(IB350,0))
- +7 ;non parent
- if IB350'=$PIECE(IBINF,"^",16)
- QUIT
- +8 ;non inpatient
- if $PIECE($PIECE(IBINF,"^",4),"
- QUIT
- +9 if $PIECE($PIECE(IBINF,"^",4),"
- SET IBFL=IB350
- End DoDot:2
- End DoDot:1
- +10 QUIT IBFL_"^"_$PIECE($GET(IBINF),"^",3)
- +11 ;
- +12 ;edit #350 event entry
- +13 ;IBIENCL - ien of #350
- +14 ;IBLSTDT = DATE LAST BILLED
- +15 ;IBADM - ien in #405
- STAT350(IBIENCL,IBLSTDT,IBADM) ;
- +1 NEW IBIENS,IBFDA,IBERR,IBDFN1
- +2 SET IBDFN1=$PIECE($GET(^IB(IBIENCL,0)),"^",2)
- +3 if +IBDFN1=0
- QUIT
- +4 ; "D0,"
- SET IBIENS=IBIENCL_","
- +5 SET IBFDA(350,IBIENS,13)=+$GET(DUZ)
- +6 if '$PIECE($GET(^IB(IBIENCL,0)),"^",17)
- SET IBFDA(350,IBIENS,.17)=(+$GET(^DGPM(IBADM,0)))\1
- +7 SET IBFDA(350,IBIENS,.18)=(+$GET(IBLSTDT))\1
- +8 DO NOW^%DTC
- SET IBD=%
- +9 SET IBFDA(350,IBIENS,14)=IBD
- +10 DO FILE^DIE("","IBFDA","IBERR")
- +11 IF $DATA(IBERR)
- Begin DoDot:1
- +12 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBIENCL),"BILLING ACTION:","closing parent entry"_$GET(IBERR("DIERR",1,"TEXT",1)))
- End DoDot:1
- +13 QUIT
- +14 ;------
- +15 ;create a new inpatient parent event entry in #350
- +16 ;Input:
- +17 ;DFN - patient's ien #2
- +18 ;IBADMIEN - admission ien #405
- +19 ;IBEVDT - event date (piece 17) for parent entry must be an admission date,
- +20 ;IBNH:
- +21 ; 1 - for 56 (#350.1) NHCU ADMISSION
- +22 ; 93 - for 93 (#350.1) LTC ADMISSION
- +23 ; 0 - all other events
- +24 ;Returns:
- +25 ;New ien of #350 Or 0 if not created
- CREV350(DFN,IBADMIEN,IBEVDT,IBNH) ;
- +1 if IBEVDT=0
- QUIT 0
- +2 NEW IBEVDA,IBSL,IBSERV
- +3 SET IBEVDA=0
- +4 DO SERV^IBAUTL2
- +5 IF '$DATA(IBSITE)!('$DATA(IBFAC))
- DO SITE^IBAUTL
- +6 SET IBSL="405:"_IBADMIEN
- +7 ;if LTC ADMISSION set IBNHLTC
- +8 IF IBNH=93
- NEW IBNHLTC
- SET IBNHLTC=93
- +9 DO EVADD^IBAUTL3
- +10 QUIT IBEVDA
- +11 ;
- +12 ;Find original admission ien, considering ASIH movements
- +13 ;Input: ien of 405 that can be "child", for example
- +14 ; we have ien of Nursing Home admission
- +15 ; then patient moved to ASIH to hospital
- +16 ; if IBA is ASIH hospital admission ien then call will return
- +17 ; "original" Nursing Home admission's ien
- +18 ;Output: ien of 405 of "original" admission
- ORIGADM(IBA) ;
- +1 NEW X,Y,Z
- SET Z=IBA
- +2 FOR
- SET X=$GET(^DGPM(Z,0))
- SET Y=$PIECE(X,"^",21)
- if Y=""
- QUIT
- SET Z=+$PIECE($GET(^DGPM(Y,0)),"^",14)
- +3 QUIT +Z
- +4 ;
- +5 ;most recent treating specialty
- +6 ;input:
- +7 ;IBDFN - patient ien
- +8 ;IB405ADM - admission's #405 ien
- +9 ;output:
- +10 ;returns ien of SPECIALTY FILE (#42.4)
- LASTTS(IBDFN,IB405ADM) ;
- +1 NEW IBDT6,IBSPEC
- +2 SET IBDT6=0
- +3 SET IBDT6=+$ORDER(^DGPM("ATS",IBDFN,IB405ADM,IBDT6))
- +4 ;error
- if +IBDT6=0
- QUIT -1
- +5 SET IBSPEC=$ORDER(^DGPM("ATS",IBDFN,IB405ADM,IBDT6,0))
- +6 ;error
- if +IBSPEC=0
- QUIT -1
- +7 ;convert fac spec (45.7) -> treat spec (#42.4)
- +8 SET IBSPEC=+$PIECE($GET(^DIC(45.7,IBSPEC,0)),"^",2)
- +9 if +IBSPEC=0
- QUIT -1
- +10 QUIT IBSPEC
- +11 ;returns today date
- TODAY() ;
- +1 NEW X
- +2 DO NOW^%DTC
- +3 QUIT X
- +4 ;returns yesterday date
- YESTRDAY() ;
- +1 NEW X1,X2,X
- +2 SET X1=$$TODAY()
- +3 SET X2=-1
- +4 DO C^%DTC
- +5 QUIT X
- +6 ;returns 1 if the most recent treating specialty for this billable
- +7 ;event and for this date was LTC
- +8 ;DFN -patient ien
- +9 ;IBEVDA - ien of event in #350
- +10 ;IBDT - date
- ASIHORG(DFN,IBEVDA,IBDT) ;
- +1 NEW IB405
- SET IB405=+$PIECE($PIECE($GET(^IB(+IBEVDA,0)),"^",4),":",2)
- +2 if IB405=0
- QUIT 0
- +3 QUIT $$ISLTC4DT(DFN,IB405,IBDT_.2359)
- +4 ;
- +5 ;returns 1 if the most recent treating specialty for the admission
- +6 ;and the date was LTC specialty
- +7 ;otherwise returns 0 or -1
- +8 ;DFN -patient ien
- +9 ;IB405ADM - ien of #405
- +10 ;IBDT - date
- ISLTC4DT(IBDFN,IB405ADM,IBDT) ;
- +1 NEW IBDT6,IBSPEC,IBTS
- +2 SET IBDT6=9999999.9999999-IBDT
- +3 SET IBDT6=+$ORDER(^DGPM("ATS",IBDFN,IB405ADM,IBDT6))
- +4 ;error
- if +IBDT6=0
- QUIT -1
- +5 SET IBSPEC=$ORDER(^DGPM("ATS",IBDFN,IB405ADM,IBDT6,0))
- +6 ;error
- if +IBSPEC=0
- QUIT -1
- +7 ;convert fac spec (45.7) -> treat spec (#42.4)
- +8 SET IBSPEC=+$PIECE($GET(^DIC(45.7,IBSPEC,0)),"^",2)
- +9 ;is it LTC or not?
- IF IBSPEC>0
- SET IBTS=$PIECE($$TREATSP^IBAECU2(IBSPEC),"^",1)
- +10 ;unknown as Means Test
- IF IBSPEC'>0
- SET IBTS="M"
- +11 ;if TS is LTC
- IF IBTS="L"
- QUIT 1
- +12 QUIT 0
- +13 ;
- RESET ; this will reset the ^xtmp global
- +1 KILL ^XTMP("IB1010EC")
- +2 SET ^XTMP("IB1010EC",0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^LIST OF PATIENTS ALREADY REPORTED AS MISSING 1010EC INFO"
- +3 QUIT
- +4 ;