IBTRHDE ;ALB/FA - HCSR Patient Events Search ;06-JUN-2014
;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
;;Per VA Directive 6402, this routine should not be modified.
;
EN(NOMSG) ;EP
; Called from menu option: IBT HCSR NIGHTLY PROCESS designed to be scheduled
; in TaskMan to be executed once a day during off-peak hours
; Use HCSR Site Parameters to set appointment search criteria and filter
; appointments. File any appointments that match the criteria into 356.22,
; the HCS Review Transmission file
; Input: NOMSG - 1 to not display locked message. Only set to 1 when
; called from REFRESH^IBTRH1A to refresh the worklist
; screen.
; Optional, defaults to 0
N $ES,$ET,HCSR
S:'$D(NOMSG) NOMSG=0
S $ET="D ER^IBTRHDE"
;
; Check lock
L +^TMP("IBTRHDE"):1
I '$T D Q
. I '$D(ZTSK),'NOMSG D
. . W !!,"The IBT HCSR Nightly Process is already running, please retry later."
. . D PAUSE^VALM1
. D ENX
;
; Check to see if background process has been stopped, if so quit.
I $G(ZTSTOP) D ENX Q
S HCSR=$G(^IBE(350.9,1,62)) ; HCSR Site Parameters
; First find all of the scheduled appointments that match the filter criteria
;;D FAPPTS(HCSR) ;3/21/16 JWS commented out background job creation of worklist entries
;
; Check to see if background process has been stopped, if so quit.
I $G(ZTSTOP) D ENX Q
;
; Next find all of the admissions that match the filter criteria
;;D FADMS(HCSR) ;3/21/16 JWS commented out background job creation of worklist entries
;
; Check to see if background process has been stopped, if so quit.
I $G(ZTSTOP) D ENX Q
; JWS 10/13/14 add 278x215 auto create
; perform auto 278x215 Inquiry generation
;;I $P(HCSR,"^",10)!($P(HCSR,"^",11)) D TRIG278^IBTRHDE1 ;3/21/16 JWS commented out auto-generated 278x215s
; Check to see if background process has been stopped, if so quit.
I $G(ZTSTOP) D ENX Q
;
; Finally automatically purge events
D PURGE(HCSR)
D ENX
Q
;
ENX ; Purge task record - if queued
I $D(ZTQUEUED) S ZTREQ="@"
L -^TMP("IBTRHDE")
Q
;
FAPPTS(HCSR) ; Finds all appointments that match the filter criteria. Each
; found appointment is then further filtered using the HCSR Site Parameters.
; Appointments that match the filter criteria are then filed into the HCS
; Review Transmission file (356.22)
; Input: HSCR - HCSR Site Parameter filters
; Output: Filtered appointments filed into 356.22
N ADATE,AINS,AINSIX,CLINIC,DFN,INSIEN,SDATE,SDCOUNT,SFILT,XX,NODE0
K ^TMP($J,"SDAMA301")
D SETFILTS(HCSR,.SFILT) ; Set Appointment filters
S SDCOUNT=$$SDAPI^SDAMA301(.SFILT) ; Find the appointments, DBIA4433
Q:SDCOUNT<1 ; No appointments returned
;
; Check the active insurance for every found filter against the HCSR Site
; parameter list of insurance companies to exclude
S DFN="" F S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN="" D
.; loop through Appointment Date/time
.S ADATE="" F S ADATE=$O(^TMP($J,"SDAMA301",DFN,ADATE)) Q:ADATE="" D
..D CKAFINS(HCSR,DFN,ADATE,65,.AINS) ; Check for valid Insurance(s)
..S AINSIX="" F S AINSIX=$O(AINS(AINSIX)) Q:AINSIX="" D
...S CLINIC=$P($P(^TMP($J,"SDAMA301",DFN,ADATE),U,2),";",1)
...; check for clinic inclusion
...; 8/20/15 jws - if clinic is not defined
...I '$O(^IBE(350.9,1,63,"B",CLINIC,"")) Q
...I '$$CHKLIST(63,$O(^IBE(350.9,1,63,"B",CLINIC,"")),$P(AINS(AINSIX),U)) Q
...; File the event
...; Appointment Date/Time is the 'IEN' of the appointment
...S NODE0=$$NOW^XLFDT()_U_DFN_U_AINSIX_"^O^^"_CLINIC_U_ADATE_U_ADATE
...D SETEVENT(NODE0)
...Q
..Q
.Q
K ^TMP($J,"SDAMA301")
Q
;
FADMS(HCSR) ; Finds all admissions that match the filter criteria. Each found
; admission is then further filtered using the HCSR Site Parameters.
; Admissions that match the filter criteria are then filed into the HCS
; Review Transmission file (356.22)
; Input: HSCR - HCSR Site Parameter filters
; Output: Filtered admissions filed into 356.22
N AINS,AINSIX,DA,DATEC,DATEE,DATES,DFN,IBWARD,NODE0,XX,YY
D GETDAYS2(HCSR,.DATES,.DATEE)
D DT^DILF("","T-"_(DATES-1),.DATEC) ; Past Admission Search date
D DT^DILF("","T+"_DATEE,.DATEE) ; Future Admission Search date
;
; First check past/present admissions
F S DATEC=$O(^DGPM("AMV1",DATEC)) Q:(DATEC="")!($P(DATEC,".")>DATEE) D ; DBIA419
.S DFN="" F S DFN=$O(^DGPM("AMV1",DATEC,DFN)) Q:DFN="" D
..S DA="" F S DA=$O(^DGPM("AMV1",DATEC,DFN,DA)) Q:DA="" D
...S IBWARD=$$GET1^DIQ(405,DA_",",.06,"I")
...D CKAFINS(HCSR,DFN,DATEC,66,.AINS) ; Check for valid Insurance(s)
...S AINSIX="" F S AINSIX=$O(AINS(AINSIX)) Q:AINSIX="" D
....; check for ward inclusion
....; 8/20/15 jws - if ward is not defined
....I '$O(^IBE(350.9,1,64,"B",IBWARD,"")) Q
....I '$$CHKLIST(64,$O(^IBE(350.9,1,64,"B",IBWARD,"")),$P(AINS(AINSIX),U)) Q
....; File the event
....S XX=DATEC
....S YY=$$GET1^DIQ(405,DA_",",.17,"I") ; Is there a Discharge
....I YY'="" D ; Get External Discharge Date
.....S YY=$$GET1^DIQ(405,DA_",",.01,"I") ; Discharge Date/Time
.....S XX=XX_"-"_YY
.....Q
....S NODE0=$$NOW^XLFDT()_U_DFN_U_AINSIX_"^I^"_IBWARD_"^^"_XX_U_$P(DATEC,".",1)
....D SETEVENT(NODE0)
....Q
...Q
..Q
.Q
;
; Next check future admissions
D DT^DILF("","T-"_(DATES-1),.DATEC) ; Past Admission Search date
F S DATEC=$O(^DGS(41.1,"C",DATEC)) Q:(DATEC="")!($P(DATEC,".")>DATEE) D ; DBIA429
.S DA="" F S DA=$O(^DGS(41.1,"C",DATEC,DA)) Q:DA="" D
..Q:$P($G(^DGS(41.1,DA,0)),U,13)'="" ; Future Admission was cancelled
..S IBWARD=$$GET1^DIQ(41.1,DA_",",8,"I")
..S DFN=$$GET1^DIQ(41.1,DA_",",.01,"I") ; Patient DFN
..D CKAFINS(HCSR,DFN,DATEC,66,.AINS) ; Check for valid Insurance(s)
..S AINSIX="" F S AINSIX=$O(AINS(AINSIX)) Q:AINSIX="" D
...; check for ward inclusion
...I '$$CHKLIST(64,$O(^IBE(350.9,1,64,"B",IBWARD,"")),$P(AINS(AINSIX),U)) Q
...; File the event
...S NODE0=$$NOW^XLFDT()_U_DFN_U_AINSIX_"^I^"_IBWARD_"^^"_DATEC_U_$P(DATEC,".",1)
...D SETEVENT(NODE0)
...Q
..Q
.Q
Q
;
PURGE(HCSR) ; Purge events that were created based upon the HCSR purge
; parameter
; Input: HSCR - HCSR Site Parameter filters
; Output: Events are deleted from into 356.22
N DA,DIK,PDATE,PDAYS,TDATE
S PDAYS=$P(HCSR,"^",9) ; Purge Days Parameter
D DT^DILF("","T-"_PDAYS,.PDATE) ; Purge events up to PDATE
S DIK="^IBT(356.22,"
S TDATE=PDATE
F D Q:(TDATE="")!(TDATE'<PDATE)
. S TDATE=$O(^IBT(356.22,"B",TDATE),-1)
. Q:(TDATE="")!(TDATE'<PDATE)
. S DA=""
. F D Q:DA=""
. . S DA=$O(^IBT(356.22,"B",TDATE,DA))
. . Q:DA=""
. . D ^DIK
Q
;
SETFILTS(HCSR,SFILT) ; Set the Appointment Search filters
; Input: HCSR - HCSR Site Parameters
; Output: SFILT() - Array of Appointment Search filters
N DATEE,DATES,SDATE,IX,IEN
;
; Determine the maximum date range to be searched
D GETDAYS1(HCSR,.DATES,.DATEE)
D DT^DILF("","T-"_DATES,.SDATE) ; Past Appt Search date
S SFILT(1)=SDATE
D DT^DILF("","T+"_DATEE,.SDATE) ; Future Appt Search date
S $P(SFILT(1),";",2)=SDATE
S SFILT(3)="R;I;NT" ; Schedule/Kept Appointment filter
S SFILT("FLDS")="1;2;3;4;10;12" ; list of fields to return
S SFILT("SORT")="P" ; Sort by Patient DFN only
Q
;
GETDAYS1(HCSR,DATES,DATEE) ; Checks the HCSR Site Parameters to get the
; maximum date range to be use when search for appointments
; Input: HCSR - HCSR Site Parameters
; Output: DATES - Internal fileman date to begin start search on
; DATEE - Internal fileman date to end search after
;
; Find the site parameter with the greatest number of days
S DATES=$P(HCSR,"^",3) ; Past Appointment Search Days
S:$P(HCSR,"^",7)>DATES DATES=$P(HCSR,"^",7) ; TRICARE Past Appt Search Days
;
; Find the site parameter with the greatest number of days
S DATEE=$P(HCSR,"^",13) ; Future Appointment Search Days
S:$P(HCSR,"^",5)>DATEE DATEE=$P(HCSR,"^",5) ; TRICARE Future Appt Search Days
Q
;
GETDAYS2(HCSR,DATES,DATEE) ; Checks the HCSR Site Parameters to get the
; maximum date range to use when searching for admissions
; Input: HCSR - HCSR Site Parameters
; Output: DATES - Internal fileman date to begin start search on
; DATEE - Internal fileman date to end search after
;
; Find the site parameter with the greatest number of days
S DATES=$P(HCSR,"^",4) ; Past Admission Search Days
S:$P(HCSR,"^",8)>DATES DATES=$P(HCSR,"^",8) ; TRICARE Past Admission Search Days
;
; Find the site parameter with the greatest number of days
S DATEE=$P(HCSR,"^",2) ; Future Admission Search Days
S:$P(HCSR,"^",6)>DATEE DATEE=$P(HCSR,"^",6) ; TRICARE future Admission Search Days
Q
;
CKAFINS(HCSR,DFN,ADATE,WHICH,AINS,DATECHK) ; Checks to see if the selected patient
; has active insurance(S) that are valid for HCSR Site Parameter filter
; criteria
; Input: HCSR - HCSR Site Parameters
; DFN - Internal Patient IEN
; ADATE - Internal Fileman date to check for 'active'
; WHICH - 65 - Checking for an appointment
; 66 - Checking for an admission
; Output: AINS() - Array of all of the active insurances that are valid
N COB,IBWARD,INSDATA,INSIEN,INSIX,INSNAME,STOP,TDATE,TRICARE,XX
K AINS
D ALL^IBCNS1(DFN,"INSDATA",1,ADATE)
;
; No active insurance for specified date
I '$G(INSDATA(0)) Q 0
S INSIX=0
F D Q:+INSIX=0
. S INSIX=$O(INSDATA(INSIX))
. Q:+INSIX=0
. S TRICARE=0,STOP=0
. S INSIEN=$P(INSDATA(INSIX,0),"^",1)
. S COB=$P(INSDATA(INSIX,0),"^",20)
. S INSNAME=$$GET1^DIQ(36,INSIEN_",",.01) ; Insurance Company Name
. S INSNAME=$$UP^XLFSTR(INSNAME)
. I (INSNAME["TRICARE")!(INSNAME["CHAMPVA") D
. . S TRICARE=1
. ;
. ; Check if the Insurance is TRICARE or CHAMPVA and then make sure that the
. ; date being checked is valid for the type of insurance
. I WHICH=65,'+$G(DATECHK) D Q:STOP
. . I 'TRICARE D Q
. . . S XX=$P(HCSR,"^",3) ; Past Appt Days
. . . D DT^DILF("","T-"_XX,.TDATE) ; Past Appt Search date
. . . I ADATE<TDATE S STOP=1 Q ; Date<Past Appt Date
. . . S XX=$P(HCSR,"^",13) ; Future Appt Days
. . . D DT^DILF("","T+"_XX,.TDATE) ; Future Appt Search date
. . . I ADATE>TDATE S STOP=1 Q ; Date>Future Appt Date
. . S XX=$P(HCSR,"^",7) ; TRICARE Past Appt Days
. . D DT^DILF("","T-"_XX,.TDATE) ; TRICARE Past Appt Search date
. . I ADATE<TDATE S STOP=1 Q ; Date<Past TRICARE Appt Date
. . S XX=$P(HCSR,"^",5) ; TRICARE Future Appt Days
. . D DT^DILF("","T+"_XX,.TDATE) ; TRICARE Future Appt Search date
. . I ADATE>TDATE S STOP=1 Q ; Date>Future TRICARE Appt Date
. ;
. I WHICH=66,'+$G(DATECHK) D Q:STOP
. . I 'TRICARE D Q
. . . S XX=$P(HCSR,"^",4) ; Past Admission Days
. . . D DT^DILF("","T-"_XX,.TDATE) ; Past Admission Search date
. . . I ADATE<TDATE S STOP=1 Q ; Date<Past Admission Date
. . . S XX=$P(HCSR,"^",2) ; Future Admission Days
. . . D DT^DILF("","T+"_XX,.TDATE) ; Future Admission Search date
. . . I ADATE>TDATE S STOP=1 Q ; Date>Future Admission Date
. . S XX=$P(HCSR,"^",8) ; TRICARE Past Admission Days
. . D DT^DILF("","T-"_XX,.TDATE) ; TRICARE Past Admission Search date
. . I ADATE<TDATE S STOP=1 Q ; Date<Past TRICARE Admission Date
. . S XX=$P(HCSR,"^",6) ; TRICARE Future Admission Days
. . D DT^DILF("","T+"_XX,.TDATE) ; TRICARE Future Admission Search date
. . I ADATE>TDATE S STOP=1 Q ; Date>Future TRICARE Admission Date
. ;
. I $D(^IBE(350.9,1,WHICH,"B",INSIEN)) D ; On the inclusion list
. . S AINS(INSIX)=INSIEN_"^"_COB
Q
;
SETEVENT(NODE0) ; Set Events into the HCS Review Transmission file (356.22)
; Input: NODE0 - A1^A2^...^An Where:
; A1 - External date of when event was filed
; A2 - Internal Patient DFN event is for
; A3 - Insurance multiple IEN
; A4 - Status. 'I' for Admission, 'O' for appointment
; A5 - Internal Ward IEN (file 42) if event is an
; admission, null otherwise
; A6 - Internal Clinic IEN (file 44) if event is an
; appointment, null otherwise
; A7 - Internal fileman date (or date range) of the event
; (appointment or admission date)
; NOTE: if admission, this is B1-B2 Where:
; B1 - Internal Admission Start Date
; B2 - Internal Admission Discharge Date
; A8 - Source identifier - Internal fileman date/time of
; the appointment or the Internal fileman date of the
; admission that caused the event creation. Used in
; Conjunction with the patient's DFN and Insurance IEN
; to prevent the creation of 'duplicate' entries
; Output: Event is filed into the HCS Review Transmission file (356.22)
N DFN,FDA,IEN,INSMIEN,SOURCE,STATUS
S DFN=$P(NODE0,"^",2)
S STATUS=$P(NODE0,"^",4)
S SOURCE=$P(NODE0,"^",8)
S INSMIEN=$P(NODE0,"^",3)
;
; Quit if we already have an event for this Status, Ins IEN and Source IEN
Q:$D(^IBT(356.22,"E",DFN,STATUS,INSMIEN,SOURCE))
;
S FDA(356.22,"+1,",.01)=$P(NODE0,"^",1)
S FDA(356.22,"+1,",.02)=DFN
S FDA(356.22,"+1,",.03)=INSMIEN
S FDA(356.22,"+1,",.04)=STATUS
S FDA(356.22,"+1,",.05)=$P(NODE0,"^",5)
S FDA(356.22,"+1,",.06)=$P(NODE0,"^",6)
S FDA(356.22,"+1,",.08)=0 ; Set initial status to 0
S FDA(356.22,"+1,",.07)=$P($P(NODE0,U,7),"-") ; force single date
; IF $P($P(NODE0,"^",7),"-",2)'="" S FDA(356.22,"+1,",2.22)=$P($P($P(NODE0,"^",7),"-",2),".")
S FDA(356.22,"+1,",.16)=SOURCE
; JWS 4/2/15 added check for service line data, then if HSD 01 and HSD 02 values do not exist for 2000E loop, default
; them to HSD01='VS' and HSD02=1 for outpatient, HSD01='DY' and HSD02=1 for inpatient
S FDA(356.22,"+1,",4.01)=$$FIND1^DIC(365.016,,,$S(STATUS="I":"DY",1:"VS")) ; quantity qualifier
S FDA(356.22,"+1,",4.02)=1 ; unit count
D UPDATE^DIE("","FDA")
Q
;
ER ; Unlock the IBT HCSR Nightly Process and return to log error
L -^TMP("IBTRHDE")
D ^%ZTER
D UNWIND^%ZTER
Q
;
CHKLIST(NODE,LISTIEN,INSIEN) ; check site parameters and determine if clinic/ward + payer combination is on the list
;
; NODE = 63 - for Clinic Search inclusion list
; 64 - for Ward Search inclusion list
;
; LISTIEN - IEN in sub-file 350.963 for clinics or 350.964 for wards
;
; INSIEN - IEN in file 36
;
; returns 1 if clinic + payer or ward + payer should be included, 0 otherwise
;
N PYRIEN,RES,Z
S RES=0
I +$G(LISTIEN),+$G(INSIEN) D
.; file event if clinic / ward is associated with all payers
.I $$ISALL^IBJPC3(NODE,LISTIEN) S RES=1 Q
.; don't file event if clinic / ward is associated with zero payers
.I $$GETTOT^IBJPC3(NODE,LISTIEN)'>0 S RES=0 Q
.S PYRIEN=+$$GET1^DIQ(36,INSIEN_",",3.1,"I") I PYRIEN'>0 Q
.; if payer associated with this ins. co. is on the list - file event
.I +$O(^IBE(350.9,1,NODE,LISTIEN,1,"B",PYRIEN,""))>0 S RES=1
.Q
Q RES
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRHDE 16258 printed Nov 22, 2024@17:38:25 Page 2
IBTRHDE ;ALB/FA - HCSR Patient Events Search ;06-JUN-2014
+1 ;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN(NOMSG) ;EP
+1 ; Called from menu option: IBT HCSR NIGHTLY PROCESS designed to be scheduled
+2 ; in TaskMan to be executed once a day during off-peak hours
+3 ; Use HCSR Site Parameters to set appointment search criteria and filter
+4 ; appointments. File any appointments that match the criteria into 356.22,
+5 ; the HCS Review Transmission file
+6 ; Input: NOMSG - 1 to not display locked message. Only set to 1 when
+7 ; called from REFRESH^IBTRH1A to refresh the worklist
+8 ; screen.
+9 ; Optional, defaults to 0
+10 NEW $ESTACK,$ETRAP,HCSR
+11 if '$DATA(NOMSG)
SET NOMSG=0
+12 SET $ETRAP="D ER^IBTRHDE"
+13 ;
+14 ; Check lock
+15 LOCK +^TMP("IBTRHDE"):1
+16 IF '$TEST
Begin DoDot:1
+17 IF '$DATA(ZTSK)
IF 'NOMSG
Begin DoDot:2
+18 WRITE !!,"The IBT HCSR Nightly Process is already running, please retry later."
+19 DO PAUSE^VALM1
End DoDot:2
+20 DO ENX
End DoDot:1
QUIT
+21 ;
+22 ; Check to see if background process has been stopped, if so quit.
+23 IF $GET(ZTSTOP)
DO ENX
QUIT
+24 ; HCSR Site Parameters
SET HCSR=$GET(^IBE(350.9,1,62))
+25 ; First find all of the scheduled appointments that match the filter criteria
+26 ;;D FAPPTS(HCSR) ;3/21/16 JWS commented out background job creation of worklist entries
+27 ;
+28 ; Check to see if background process has been stopped, if so quit.
+29 IF $GET(ZTSTOP)
DO ENX
QUIT
+30 ;
+31 ; Next find all of the admissions that match the filter criteria
+32 ;;D FADMS(HCSR) ;3/21/16 JWS commented out background job creation of worklist entries
+33 ;
+34 ; Check to see if background process has been stopped, if so quit.
+35 IF $GET(ZTSTOP)
DO ENX
QUIT
+36 ; JWS 10/13/14 add 278x215 auto create
+37 ; perform auto 278x215 Inquiry generation
+38 ;;I $P(HCSR,"^",10)!($P(HCSR,"^",11)) D TRIG278^IBTRHDE1 ;3/21/16 JWS commented out auto-generated 278x215s
+39 ; Check to see if background process has been stopped, if so quit.
+40 IF $GET(ZTSTOP)
DO ENX
QUIT
+41 ;
+42 ; Finally automatically purge events
+43 DO PURGE(HCSR)
+44 DO ENX
+45 QUIT
+46 ;
ENX ; Purge task record - if queued
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 LOCK -^TMP("IBTRHDE")
+3 QUIT
+4 ;
FAPPTS(HCSR) ; Finds all appointments that match the filter criteria. Each
+1 ; found appointment is then further filtered using the HCSR Site Parameters.
+2 ; Appointments that match the filter criteria are then filed into the HCS
+3 ; Review Transmission file (356.22)
+4 ; Input: HSCR - HCSR Site Parameter filters
+5 ; Output: Filtered appointments filed into 356.22
+6 NEW ADATE,AINS,AINSIX,CLINIC,DFN,INSIEN,SDATE,SDCOUNT,SFILT,XX,NODE0
+7 KILL ^TMP($JOB,"SDAMA301")
+8 ; Set Appointment filters
DO SETFILTS(HCSR,.SFILT)
+9 ; Find the appointments, DBIA4433
SET SDCOUNT=$$SDAPI^SDAMA301(.SFILT)
+10 ; No appointments returned
if SDCOUNT<1
QUIT
+11 ;
+12 ; Check the active insurance for every found filter against the HCSR Site
+13 ; parameter list of insurance companies to exclude
+14 SET DFN=""
FOR
SET DFN=$ORDER(^TMP($JOB,"SDAMA301",DFN))
if DFN=""
QUIT
Begin DoDot:1
+15 ; loop through Appointment Date/time
+16 SET ADATE=""
FOR
SET ADATE=$ORDER(^TMP($JOB,"SDAMA301",DFN,ADATE))
if ADATE=""
QUIT
Begin DoDot:2
+17 ; Check for valid Insurance(s)
DO CKAFINS(HCSR,DFN,ADATE,65,.AINS)
+18 SET AINSIX=""
FOR
SET AINSIX=$ORDER(AINS(AINSIX))
if AINSIX=""
QUIT
Begin DoDot:3
+19 SET CLINIC=$PIECE($PIECE(^TMP($JOB,"SDAMA301",DFN,ADATE),U,2),";",1)
+20 ; check for clinic inclusion
+21 ; 8/20/15 jws - if clinic is not defined
+22 IF '$ORDER(^IBE(350.9,1,63,"B",CLINIC,""))
QUIT
+23 IF '$$CHKLIST(63,$ORDER(^IBE(350.9,1,63,"B",CLINIC,"")),$PIECE(AINS(AINSIX),U))
QUIT
+24 ; File the event
+25 ; Appointment Date/Time is the 'IEN' of the appointment
+26 SET NODE0=$$NOW^XLFDT()_U_DFN_U_AINSIX_"^O^^"_CLINIC_U_ADATE_U_ADATE
+27 DO SETEVENT(NODE0)
+28 QUIT
End DoDot:3
+29 QUIT
End DoDot:2
+30 QUIT
End DoDot:1
+31 KILL ^TMP($JOB,"SDAMA301")
+32 QUIT
+33 ;
FADMS(HCSR) ; Finds all admissions that match the filter criteria. Each found
+1 ; admission is then further filtered using the HCSR Site Parameters.
+2 ; Admissions that match the filter criteria are then filed into the HCS
+3 ; Review Transmission file (356.22)
+4 ; Input: HSCR - HCSR Site Parameter filters
+5 ; Output: Filtered admissions filed into 356.22
+6 NEW AINS,AINSIX,DA,DATEC,DATEE,DATES,DFN,IBWARD,NODE0,XX,YY
+7 DO GETDAYS2(HCSR,.DATES,.DATEE)
+8 ; Past Admission Search date
DO DT^DILF("","T-"_(DATES-1),.DATEC)
+9 ; Future Admission Search date
DO DT^DILF("","T+"_DATEE,.DATEE)
+10 ;
+11 ; First check past/present admissions
+12 ; DBIA419
FOR
SET DATEC=$ORDER(^DGPM("AMV1",DATEC))
if (DATEC="")!($PIECE(DATEC,".")>DATEE)
QUIT
Begin DoDot:1
+13 SET DFN=""
FOR
SET DFN=$ORDER(^DGPM("AMV1",DATEC,DFN))
if DFN=""
QUIT
Begin DoDot:2
+14 SET DA=""
FOR
SET DA=$ORDER(^DGPM("AMV1",DATEC,DFN,DA))
if DA=""
QUIT
Begin DoDot:3
+15 SET IBWARD=$$GET1^DIQ(405,DA_",",.06,"I")
+16 ; Check for valid Insurance(s)
DO CKAFINS(HCSR,DFN,DATEC,66,.AINS)
+17 SET AINSIX=""
FOR
SET AINSIX=$ORDER(AINS(AINSIX))
if AINSIX=""
QUIT
Begin DoDot:4
+18 ; check for ward inclusion
+19 ; 8/20/15 jws - if ward is not defined
+20 IF '$ORDER(^IBE(350.9,1,64,"B",IBWARD,""))
QUIT
+21 IF '$$CHKLIST(64,$ORDER(^IBE(350.9,1,64,"B",IBWARD,"")),$PIECE(AINS(AINSIX),U))
QUIT
+22 ; File the event
+23 SET XX=DATEC
+24 ; Is there a Discharge
SET YY=$$GET1^DIQ(405,DA_",",.17,"I")
+25 ; Get External Discharge Date
IF YY'=""
Begin DoDot:5
+26 ; Discharge Date/Time
SET YY=$$GET1^DIQ(405,DA_",",.01,"I")
+27 SET XX=XX_"-"_YY
+28 QUIT
End DoDot:5
+29 SET NODE0=$$NOW^XLFDT()_U_DFN_U_AINSIX_"^I^"_IBWARD_"^^"_XX_U_$PIECE(DATEC,".",1)
+30 DO SETEVENT(NODE0)
+31 QUIT
End DoDot:4
+32 QUIT
End DoDot:3
+33 QUIT
End DoDot:2
+34 QUIT
End DoDot:1
+35 ;
+36 ; Next check future admissions
+37 ; Past Admission Search date
DO DT^DILF("","T-"_(DATES-1),.DATEC)
+38 ; DBIA429
FOR
SET DATEC=$ORDER(^DGS(41.1,"C",DATEC))
if (DATEC="")!($PIECE(DATEC,".")>DATEE)
QUIT
Begin DoDot:1
+39 SET DA=""
FOR
SET DA=$ORDER(^DGS(41.1,"C",DATEC,DA))
if DA=""
QUIT
Begin DoDot:2
+40 ; Future Admission was cancelled
if $PIECE($GET(^DGS(41.1,DA,0)),U,13)'=""
QUIT
+41 SET IBWARD=$$GET1^DIQ(41.1,DA_",",8,"I")
+42 ; Patient DFN
SET DFN=$$GET1^DIQ(41.1,DA_",",.01,"I")
+43 ; Check for valid Insurance(s)
DO CKAFINS(HCSR,DFN,DATEC,66,.AINS)
+44 SET AINSIX=""
FOR
SET AINSIX=$ORDER(AINS(AINSIX))
if AINSIX=""
QUIT
Begin DoDot:3
+45 ; check for ward inclusion
+46 IF '$$CHKLIST(64,$ORDER(^IBE(350.9,1,64,"B",IBWARD,"")),$PIECE(AINS(AINSIX),U))
QUIT
+47 ; File the event
+48 SET NODE0=$$NOW^XLFDT()_U_DFN_U_AINSIX_"^I^"_IBWARD_"^^"_DATEC_U_$PIECE(DATEC,".",1)
+49 DO SETEVENT(NODE0)
+50 QUIT
End DoDot:3
+51 QUIT
End DoDot:2
+52 QUIT
End DoDot:1
+53 QUIT
+54 ;
PURGE(HCSR) ; Purge events that were created based upon the HCSR purge
+1 ; parameter
+2 ; Input: HSCR - HCSR Site Parameter filters
+3 ; Output: Events are deleted from into 356.22
+4 NEW DA,DIK,PDATE,PDAYS,TDATE
+5 ; Purge Days Parameter
SET PDAYS=$PIECE(HCSR,"^",9)
+6 ; Purge events up to PDATE
DO DT^DILF("","T-"_PDAYS,.PDATE)
+7 SET DIK="^IBT(356.22,"
+8 SET TDATE=PDATE
+9 FOR
Begin DoDot:1
+10 SET TDATE=$ORDER(^IBT(356.22,"B",TDATE),-1)
+11 if (TDATE="")!(TDATE'<PDATE)
QUIT
+12 SET DA=""
+13 FOR
Begin DoDot:2
+14 SET DA=$ORDER(^IBT(356.22,"B",TDATE,DA))
+15 if DA=""
QUIT
+16 DO ^DIK
End DoDot:2
if DA=""
QUIT
End DoDot:1
if (TDATE="")!(TDATE'<PDATE)
QUIT
+17 QUIT
+18 ;
SETFILTS(HCSR,SFILT) ; Set the Appointment Search filters
+1 ; Input: HCSR - HCSR Site Parameters
+2 ; Output: SFILT() - Array of Appointment Search filters
+3 NEW DATEE,DATES,SDATE,IX,IEN
+4 ;
+5 ; Determine the maximum date range to be searched
+6 DO GETDAYS1(HCSR,.DATES,.DATEE)
+7 ; Past Appt Search date
DO DT^DILF("","T-"_DATES,.SDATE)
+8 SET SFILT(1)=SDATE
+9 ; Future Appt Search date
DO DT^DILF("","T+"_DATEE,.SDATE)
+10 SET $PIECE(SFILT(1),";",2)=SDATE
+11 ; Schedule/Kept Appointment filter
SET SFILT(3)="R;I;NT"
+12 ; list of fields to return
SET SFILT("FLDS")="1;2;3;4;10;12"
+13 ; Sort by Patient DFN only
SET SFILT("SORT")="P"
+14 QUIT
+15 ;
GETDAYS1(HCSR,DATES,DATEE) ; Checks the HCSR Site Parameters to get the
+1 ; maximum date range to be use when search for appointments
+2 ; Input: HCSR - HCSR Site Parameters
+3 ; Output: DATES - Internal fileman date to begin start search on
+4 ; DATEE - Internal fileman date to end search after
+5 ;
+6 ; Find the site parameter with the greatest number of days
+7 ; Past Appointment Search Days
SET DATES=$PIECE(HCSR,"^",3)
+8 ; TRICARE Past Appt Search Days
if $PIECE(HCSR,"^",7)>DATES
SET DATES=$PIECE(HCSR,"^",7)
+9 ;
+10 ; Find the site parameter with the greatest number of days
+11 ; Future Appointment Search Days
SET DATEE=$PIECE(HCSR,"^",13)
+12 ; TRICARE Future Appt Search Days
if $PIECE(HCSR,"^",5)>DATEE
SET DATEE=$PIECE(HCSR,"^",5)
+13 QUIT
+14 ;
GETDAYS2(HCSR,DATES,DATEE) ; Checks the HCSR Site Parameters to get the
+1 ; maximum date range to use when searching for admissions
+2 ; Input: HCSR - HCSR Site Parameters
+3 ; Output: DATES - Internal fileman date to begin start search on
+4 ; DATEE - Internal fileman date to end search after
+5 ;
+6 ; Find the site parameter with the greatest number of days
+7 ; Past Admission Search Days
SET DATES=$PIECE(HCSR,"^",4)
+8 ; TRICARE Past Admission Search Days
if $PIECE(HCSR,"^",8)>DATES
SET DATES=$PIECE(HCSR,"^",8)
+9 ;
+10 ; Find the site parameter with the greatest number of days
+11 ; Future Admission Search Days
SET DATEE=$PIECE(HCSR,"^",2)
+12 ; TRICARE future Admission Search Days
if $PIECE(HCSR,"^",6)>DATEE
SET DATEE=$PIECE(HCSR,"^",6)
+13 QUIT
+14 ;
CKAFINS(HCSR,DFN,ADATE,WHICH,AINS,DATECHK) ; Checks to see if the selected patient
+1 ; has active insurance(S) that are valid for HCSR Site Parameter filter
+2 ; criteria
+3 ; Input: HCSR - HCSR Site Parameters
+4 ; DFN - Internal Patient IEN
+5 ; ADATE - Internal Fileman date to check for 'active'
+6 ; WHICH - 65 - Checking for an appointment
+7 ; 66 - Checking for an admission
+8 ; Output: AINS() - Array of all of the active insurances that are valid
+9 NEW COB,IBWARD,INSDATA,INSIEN,INSIX,INSNAME,STOP,TDATE,TRICARE,XX
+10 KILL AINS
+11 DO ALL^IBCNS1(DFN,"INSDATA",1,ADATE)
+12 ;
+13 ; No active insurance for specified date
+14 IF '$GET(INSDATA(0))
QUIT 0
+15 SET INSIX=0
+16 FOR
Begin DoDot:1
+17 SET INSIX=$ORDER(INSDATA(INSIX))
+18 if +INSIX=0
QUIT
+19 SET TRICARE=0
SET STOP=0
+20 SET INSIEN=$PIECE(INSDATA(INSIX,0),"^",1)
+21 SET COB=$PIECE(INSDATA(INSIX,0),"^",20)
+22 ; Insurance Company Name
SET INSNAME=$$GET1^DIQ(36,INSIEN_",",.01)
+23 SET INSNAME=$$UP^XLFSTR(INSNAME)
+24 IF (INSNAME["TRICARE")!(INSNAME["CHAMPVA")
Begin DoDot:2
+25 SET TRICARE=1
End DoDot:2
+26 ;
+27 ; Check if the Insurance is TRICARE or CHAMPVA and then make sure that the
+28 ; date being checked is valid for the type of insurance
+29 IF WHICH=65
IF '+$GET(DATECHK)
Begin DoDot:2
+30 IF 'TRICARE
Begin DoDot:3
+31 ; Past Appt Days
SET XX=$PIECE(HCSR,"^",3)
+32 ; Past Appt Search date
DO DT^DILF("","T-"_XX,.TDATE)
+33 ; Date<Past Appt Date
IF ADATE<TDATE
SET STOP=1
QUIT
+34 ; Future Appt Days
SET XX=$PIECE(HCSR,"^",13)
+35 ; Future Appt Search date
DO DT^DILF("","T+"_XX,.TDATE)
+36 ; Date>Future Appt Date
IF ADATE>TDATE
SET STOP=1
QUIT
End DoDot:3
QUIT
+37 ; TRICARE Past Appt Days
SET XX=$PIECE(HCSR,"^",7)
+38 ; TRICARE Past Appt Search date
DO DT^DILF("","T-"_XX,.TDATE)
+39 ; Date<Past TRICARE Appt Date
IF ADATE<TDATE
SET STOP=1
QUIT
+40 ; TRICARE Future Appt Days
SET XX=$PIECE(HCSR,"^",5)
+41 ; TRICARE Future Appt Search date
DO DT^DILF("","T+"_XX,.TDATE)
+42 ; Date>Future TRICARE Appt Date
IF ADATE>TDATE
SET STOP=1
QUIT
End DoDot:2
if STOP
QUIT
+43 ;
+44 IF WHICH=66
IF '+$GET(DATECHK)
Begin DoDot:2
+45 IF 'TRICARE
Begin DoDot:3
+46 ; Past Admission Days
SET XX=$PIECE(HCSR,"^",4)
+47 ; Past Admission Search date
DO DT^DILF("","T-"_XX,.TDATE)
+48 ; Date<Past Admission Date
IF ADATE<TDATE
SET STOP=1
QUIT
+49 ; Future Admission Days
SET XX=$PIECE(HCSR,"^",2)
+50 ; Future Admission Search date
DO DT^DILF("","T+"_XX,.TDATE)
+51 ; Date>Future Admission Date
IF ADATE>TDATE
SET STOP=1
QUIT
End DoDot:3
QUIT
+52 ; TRICARE Past Admission Days
SET XX=$PIECE(HCSR,"^",8)
+53 ; TRICARE Past Admission Search date
DO DT^DILF("","T-"_XX,.TDATE)
+54 ; Date<Past TRICARE Admission Date
IF ADATE<TDATE
SET STOP=1
QUIT
+55 ; TRICARE Future Admission Days
SET XX=$PIECE(HCSR,"^",6)
+56 ; TRICARE Future Admission Search date
DO DT^DILF("","T+"_XX,.TDATE)
+57 ; Date>Future TRICARE Admission Date
IF ADATE>TDATE
SET STOP=1
QUIT
End DoDot:2
if STOP
QUIT
+58 ;
+59 ; On the inclusion list
IF $DATA(^IBE(350.9,1,WHICH,"B",INSIEN))
Begin DoDot:2
+60 SET AINS(INSIX)=INSIEN_"^"_COB
End DoDot:2
End DoDot:1
if +INSIX=0
QUIT
+61 QUIT
+62 ;
SETEVENT(NODE0) ; Set Events into the HCS Review Transmission file (356.22)
+1 ; Input: NODE0 - A1^A2^...^An Where:
+2 ; A1 - External date of when event was filed
+3 ; A2 - Internal Patient DFN event is for
+4 ; A3 - Insurance multiple IEN
+5 ; A4 - Status. 'I' for Admission, 'O' for appointment
+6 ; A5 - Internal Ward IEN (file 42) if event is an
+7 ; admission, null otherwise
+8 ; A6 - Internal Clinic IEN (file 44) if event is an
+9 ; appointment, null otherwise
+10 ; A7 - Internal fileman date (or date range) of the event
+11 ; (appointment or admission date)
+12 ; NOTE: if admission, this is B1-B2 Where:
+13 ; B1 - Internal Admission Start Date
+14 ; B2 - Internal Admission Discharge Date
+15 ; A8 - Source identifier - Internal fileman date/time of
+16 ; the appointment or the Internal fileman date of the
+17 ; admission that caused the event creation. Used in
+18 ; Conjunction with the patient's DFN and Insurance IEN
+19 ; to prevent the creation of 'duplicate' entries
+20 ; Output: Event is filed into the HCS Review Transmission file (356.22)
+21 NEW DFN,FDA,IEN,INSMIEN,SOURCE,STATUS
+22 SET DFN=$PIECE(NODE0,"^",2)
+23 SET STATUS=$PIECE(NODE0,"^",4)
+24 SET SOURCE=$PIECE(NODE0,"^",8)
+25 SET INSMIEN=$PIECE(NODE0,"^",3)
+26 ;
+27 ; Quit if we already have an event for this Status, Ins IEN and Source IEN
+28 if $DATA(^IBT(356.22,"E",DFN,STATUS,INSMIEN,SOURCE))
QUIT
+29 ;
+30 SET FDA(356.22,"+1,",.01)=$PIECE(NODE0,"^",1)
+31 SET FDA(356.22,"+1,",.02)=DFN
+32 SET FDA(356.22,"+1,",.03)=INSMIEN
+33 SET FDA(356.22,"+1,",.04)=STATUS
+34 SET FDA(356.22,"+1,",.05)=$PIECE(NODE0,"^",5)
+35 SET FDA(356.22,"+1,",.06)=$PIECE(NODE0,"^",6)
+36 ; Set initial status to 0
SET FDA(356.22,"+1,",.08)=0
+37 ; force single date
SET FDA(356.22,"+1,",.07)=$PIECE($PIECE(NODE0,U,7),"-")
+38 ; IF $P($P(NODE0,"^",7),"-",2)'="" S FDA(356.22,"+1,",2.22)=$P($P($P(NODE0,"^",7),"-",2),".")
+39 SET FDA(356.22,"+1,",.16)=SOURCE
+40 ; JWS 4/2/15 added check for service line data, then if HSD 01 and HSD 02 values do not exist for 2000E loop, default
+41 ; them to HSD01='VS' and HSD02=1 for outpatient, HSD01='DY' and HSD02=1 for inpatient
+42 ; quantity qualifier
SET FDA(356.22,"+1,",4.01)=$$FIND1^DIC(365.016,,,$SELECT(STATUS="I":"DY",1:"VS"))
+43 ; unit count
SET FDA(356.22,"+1,",4.02)=1
+44 DO UPDATE^DIE("","FDA")
+45 QUIT
+46 ;
ER ; Unlock the IBT HCSR Nightly Process and return to log error
+1 LOCK -^TMP("IBTRHDE")
+2 DO ^%ZTER
+3 DO UNWIND^%ZTER
+4 QUIT
+5 ;
CHKLIST(NODE,LISTIEN,INSIEN) ; check site parameters and determine if clinic/ward + payer combination is on the list
+1 ;
+2 ; NODE = 63 - for Clinic Search inclusion list
+3 ; 64 - for Ward Search inclusion list
+4 ;
+5 ; LISTIEN - IEN in sub-file 350.963 for clinics or 350.964 for wards
+6 ;
+7 ; INSIEN - IEN in file 36
+8 ;
+9 ; returns 1 if clinic + payer or ward + payer should be included, 0 otherwise
+10 ;
+11 NEW PYRIEN,RES,Z
+12 SET RES=0
+13 IF +$GET(LISTIEN)
IF +$GET(INSIEN)
Begin DoDot:1
+14 ; file event if clinic / ward is associated with all payers
+15 IF $$ISALL^IBJPC3(NODE,LISTIEN)
SET RES=1
QUIT
+16 ; don't file event if clinic / ward is associated with zero payers
+17 IF $$GETTOT^IBJPC3(NODE,LISTIEN)'>0
SET RES=0
QUIT
+18 SET PYRIEN=+$$GET1^DIQ(36,INSIEN_",",3.1,"I")
IF PYRIEN'>0
QUIT
+19 ; if payer associated with this ins. co. is on the list - file event
+20 IF +$ORDER(^IBE(350.9,1,NODE,LISTIEN,1,"B",PYRIEN,""))>0
SET RES=1
+21 QUIT
End DoDot:1
+22 QUIT RES
