BARDYSV3 ; IHS/SD/MAS,TPF - OMB - DAYS TO COLLECTION ; 02/09/2009
;;1.8;IHS ACCOUNTS RECEIVABLE;**12,13,14,16,23**;OCT 26, 2005
;
; IHS/SD/TMM 07/02/2009 M1 Routine too large. Create 2nd routine ^BARDYSV2
; IHS/SD/TMM 09/17/2009 M2 Copy BARDYSVZ to BARDYSV3 for OMB Phase II modifications
; IHS/SD/TMM 01/07/2010 M3 Record XBFLG value returned from ^XBGSAVE
; IHS/SD/TMM 01/26/2010 M4 Use 3PB DUZ2 for ^DIQ calls TO 3PB files
; IHS/SD/TMM 01/27/2010 M5 Update BATCH routine with current logic (to match INSTALL^BARDYSV4 and INTERACT)
; IHS/SD/TMM 01/29/2010 M6 Tag TRANS moved from ^BARDYSV3 to ^BARDYSV5 due to
; routine size of ^BARDYSV3 and SAC checker requirement
; MAR 2012 HEAT# 80021 P.OTTIS (=""1M" changed to ["1M")
; MAR 2012 HEAT# 55217 P.OTTIS Parker - <UNDEFINED>BATCH+36^BARDYSV3
; FEB 2013 P.OTT CHANGED PTR TO INSURER TYPE
Q
;
;IT IS EXPECTED THAT IF NO DATES ARE PASSED VIA TASKMAN THAT THE TASK WILL BE SCHEDULED
;FOR THE FIRST DAY OF THE MONTH AND THE RANGE WILL BE FROM THE 1ST TO THA LAST DAY OF THE
;MONTH BEFORE
;
;ASK DATE RANGE FIND VISITS FOR THAT RANGE IN THE VISIT FILE
INTERACT ;EP - INTERACTIVE EP
I '$$IHS(DUZ(2)) W !,"THIS REPORT IS NOT INTENDED FOR NON-IHS FACILITIES!!" W ! K DIR S DIR(0)="E" D ^DIR Q
S ZTQUEUED=$G(ZTQUEUED)
D INIT
;
ASKBEG ;EP - ASK BEGIN DATE
N BEGDATE,ENDDATE
K DIR
S DIR(0)="DO^::EX"
S DIR("A")="Enter Beginning Visit Date"
D ^DIR
Q:$D(DIRUT)!$D(DTOUT)!($D(DUOUT))!(Y="")
S BEGDATE=Y
;
ASKEND ;EP - ASK END DATE
K DIR
S DIR(0)="DO^::EX"
S DIR("A")="Enter Ending Visit Date"
D ^DIR
G:$D(DIRUT)!$D(DTOUT)!($D(DUOUT))!(Y="") ASKBEG
S ENDDATE=Y
I BEGDATE>ENDDATE W !,"BEGIN DATE CAN NOT BE GREATER THAN ENDING DATE!" K DIR S DIR(0)="E" D ^DIR G ASKEND
D NOW^%DTC
S ^BARTMP("BARDYSV3",0,"INTERACT STARTED",DUZ(2),%)=BEGDATE_U_ENDDATE
W !!
D VISITS^BARDYSV5(BEGDATE,ENDDATE)
D BILLS(BEGDATE,ENDDATE) ;M2
;D TRANS(BEGDATE,ENDDATE) ;M2 ;M6*DEL*TMM
D TRANS^BARDYSV5(BEGDATE,ENDDATE) ;M2 ;M6*ADD*TMM
I '$D(^BAROMB($J)) D G ASKBEG
. S BARTMP="NO DATA FOUND FOR OMB REPORT!"
. W !,BARTMP
. K DIR
. S DIR(0)="E"
. D ^DIR
. S ^BARTMP("BARDYSV3",0,"INTERACT COMPLETED",DUZ(2),%)=BARTMP
S RC=$$ASKFNAME^BARDYSV4(.BARFILE,BEGDATE,ENDDATE)
W !,"DESTINATION FILE: ",BARFILE
D SENDFILE^BARDYSV4("BAROMB(",BARFILE) ;M1 BAR*1.8*13 TMM
D NOW^%DTC
S ^BARTMP("BARDYSV3",0,"INTERACT COMPLETED",DUZ(2),%)="" ;M2
; Global copy to flat file successful when XBFLG=0
; XBFLG=0 (zero) Save was successful. No errors detected
; XBFLG=-1 Save was unsuccessful, If errors detected XBFLG is
; set to "-1", error info stored in XBFLG(1) and
; XBGSAVE returns to the calling program WITHOUT SAVING THE
; FILE.
; HEAT# 0055217 P.OTT
;
I $G(XBFLG)'=0 S ^BARTMP("BARDYSV3",0,"INTERACT COMPLETED",DUZ(2),%,1)="Global copy of ^BAROMB Failed"_"^"_$G(XBFLG)_"^"_$G(XBFLG(1)) ;M2 ;M3*ADD*TMM
I $G(XBFLG)=-1 S ^BARTMP("BARDYSV3",0,"INTERACT COMPLETED",DUZ(2),%,2)=XBFLG_"^"_$G(XBFLG(1)) ;M2 ;M3*ADD*TMM
I $G(XBFLG)=0 S ^BARTMP("BARDYSV3",0,"INTERACT COMPLETE",DUZ(2),%,3)="Global copy ^BAROMB successful" ;M2 ;M3*ADD*TMM
Q
;
;IT IS EXPECTED THAT IF NO DATES ARE PASSED VIA TASKMAN THAT THE TASK WILL BE SCHEDULED
;FOR THE FIRST DAY OF THE MONTH AND THE RANGE WILL BE FROM THE 1ST TO THA LAST DAY OF THE
;MONTH BEFORE
BATCH(BARBEG,BAREND) ;EP - ENTER FOR TASKED JOB
D INIT
N RANGE,BARBEG,BAREND
S ^BARTMP("BARDYSV3",0,"JOB")=$J
I $P(D,U,6)["1M" S RANGE=$$LSTMNTH(DT) S BARBEG=$P(RANGE,U),BAREND=$P(RANGE,U,2) ;P.OTT
E I $P(D,U,6)[("D") S %DT="" S X="T-"_+$P(D,U,6) D ^%DT S BARBEG=Y,BAREND=DT
D NOW^%DTC
S ^BARTMP("BARDYSV3",0,"BATCH STARTED",%)=BARBEG_U_BAREND
D VISITS^BARDYSV5(BARBEG,BAREND)
D BILLS(BARBEG,BAREND) ;M2
;D TRANS(BARBEG,BAREND) ;M2 ;M6*DEL*TMM
D TRANS^BARDYSV5(BARBEG,BAREND) ;M2 ;M6*ADD*TMM
S ^BARTMP("BARDYSV3",0,"BATCH COMPLETED",DUZ(2),%)="OMB PHASE II - Data Extracted, Ready to send"
S RC=$$ASKFNAME^BARDYSV4(.BARFILE,BARBEG,BAREND)
D SENDFILE^BARDYSV4("BAROMB(",BARFILE) ;M1 BAR*1.8*13 TMM
D NOW^%DTC
;
; HEAT# 0055217 P.OTT
;
I $G(XBFLG)'=0 S ^BARTMP("BARDYSV3",0,"BATCH COMPLETED",DUZ(2),%,1)="Global copy of ^BAROMB Failed"_"^"_$G(XBFLG)_"^"_$G(XBFLG(1)) ;M2 ;M3*ADD*TMM
I $G(XBFLG)=-1 S ^BARTMP("BARDYSV3",0,"BATCH COMPLETED",DUZ(2),%,2)=$G(XBFLG)_"^"_$G(XBFLG(1)) ;M2 ;M3*ADD*TMM
I $G(XBFLG)=0 S ^BARTMP("BARDYSV3",0,"BATCH COMPLETED",DUZ(2),%,3)="Global copy ^BAROMB successful" ;M2 ;M3*ADD*TMM
;*** M5*END ADD*TMM ***
Q
;
;COMPUTE LAST MONTH'S DAYS IN A MONTH, PASS DT. USE THIS TO GET DATE RANGE
LSTMNTH(TODAY) ;EP - COMPY
N DAYS,LSTMNTH,FMYR,STARTDAY,ENDDAY
S FMYR=$E(TODAY,1,3)
S THISMNTH=$E(TODAY,4,5)
S LSTMNTH=$E(TODAY,4,5)-1
I LSTMNTH=0 S LSTMNTH=12
S X=LSTMNTH
S X1=X,X=$S("^1^3^5^7^8^10^12^"[(U_X_U):31,X'=2:30,$E(X1,1,3)#4:28,1:29)
S STARTDAY="01"
S ENDDAY=X
S:THISMNTH="01" FMYR=FMYR-1,LSTMNTH=12
S:$L(LSTMNTH)=1 LSTMNTH="0"_LSTMNTH
S BEGIN=FMYR_LSTMNTH_STARTDAY
S END=FMYR_LSTMNTH_ENDDAY
Q BEGIN_U_END
;
IHS(DUZ2) ;EP - RETURN TRUE IF IHS AFFILIATION
N REC
S REC=$O(^AUTTLOC(DUZ2,11,""),-1)
S AFFIL=$$GET1^DIQ(9999999.0611,REC_","_DUZ2_",",.03,"I")
Q AFFIL=1 ;1 MEANS IHS
;
BILLS(BARBEG,BAREND) ;EP - Find 3P Bills for this period
;Create sort file for all 3PB's and A/R Bills, then create bill record
N CNT ;M2
S BEGIN=BARBEG-.01
S END=BAREND_".999999"
;
;Find 3P Bills for this period for all 3PB DUZ(2)
S TPBDUZ2=0 F S TPBDUZ2=$O(^ABMDBILL(TPBDUZ2)) Q:'TPBDUZ2 D
.S TPAPRVDT=BEGIN F CNT=1:1 S TPAPRVDT=$O(^ABMDBILL(TPBDUZ2,"AP",TPAPRVDT)) Q:('TPAPRVDT)!(TPAPRVDT>END) D ;3P BILL APPROVE DT/TM
..S TPBIEN="" F S TPBIEN=$O(^ABMDBILL(TPBDUZ2,"AP",TPAPRVDT,TPBIEN)) Q:'TPBIEN D ;3P BILL IEN
...S ^BARTMP("BARDYSV3",10,"BILLS",TPBIEN,0)=TPAPRVDT_U_U_TPBDUZ2 ;3PB IEN noted
;
;Now find A/R Bills for this period
N CNT ;M2
S TPAPRVDT=BEGIN F CNT=1:1 S TPAPRVDT=$O(^BARBL(DUZ(2),"AG",TPAPRVDT)) Q:('TPAPRVDT)!(TPAPRVDT>END) D
.W:'$D(ZTQUEUED)&'(CNT#1000) "."
.S BARBLIEN=$O(^BARBL(DUZ(2),"AG",TPAPRVDT,"")) Q:'BARBLIEN D
..S TPBIEN=$P($G(^BARBL(DUZ(2),BARBLIEN,0)),U,17)
..S:TPBIEN="" TPBIEN=0
..;Update ^BARTMP if doesn't exist from the 3P Bill
..S ^BARTMP("BARDYSV3",10,"BILLS",TPBIEN,BARBLIEN)=TPAPRVDT
..I $D(^BARTMP("BARDYSV3",10,"BILLS",TPBIEN,0)) S $P(^BARTMP("BARDYSV3",10,"BILLS",TPBIEN,0),U,2)="DUP"
;
;$O thru ^BARTMP and create bill records
K TMP
S BILLIEN="" F S BILLIEN=$O(^BARTMP("BARDYSV3",10,"BILLS",BILLIEN)) Q:BILLIEN="" D
.S BARBLIEN="" F S BARBLIEN=$O(^BARTMP("BARDYSV3",10,"BILLS",BILLIEN,BARBLIEN)) Q:BARBLIEN="" D
..K TMP
..I BARBLIEN=0 D
...S TMP=$G(^BARTMP("BARDYSV3",10,"BILLS",BILLIEN,BARBLIEN))
...S TMP=$P(TMP,U,2)
..I $G(TMP)="DUP" Q ;skip this one, there will be another entry with same 3PBIEN and a real BARBLIEN
..;Get the 3PB IEN DUZ2
..S TPBDUZ2=$P($G(^BARBL(DUZ(2),BARBLIEN,0)),"^",22) ;TPB DUZ(2)
..;
..;Get multiple visits for 3P Bill ;M2 20091015
..S MULTVIS="" ;M2 20091015
..I TPBDUZ2'="" S VISIT=0 F TMP=1:1 S VISIT=$O(^ABMDBILL(TPBDUZ2,BILLIEN,11,VISIT)) Q:'VISIT D ;PCC VISIT IEN ;M2 20091015
...S $P(MULTVIS,"|",TMP)=VISIT ;send all visits for this 3PB
..;M2 20091021 S MULTVIS=$S(MULTVIS["|":MULTVIS,1:"")
..;
..I TPBDUZ2'="" S VISIT=0 F S VISIT=$O(^ABMDBILL(TPBDUZ2,BILLIEN,11,VISIT)) Q:'VISIT D ;PCC VISIT IEN ;M2 20091015-moved down here from above
...S BARVLOC=$$LOCENC^APCLV(VISIT,"C") ;API LOC. OF ENCOUNTER ASUFAC ;M2
...S:BARVLOC="" BARVLOC="UNDEF" ;M2
...;*** loc testing
...;I BARVLOC="UNDEF" D
...;look at all scenarios initially
...S IENS=BILLIEN
...S SAVEDUZ=DUZ(2) ;M4*ADD*TMM
...S DUZ(2)=TPBDUZ2 ;M4*ADD*TMM
...S TPBVLOC=$$GET1^DIQ(9002274.4,IENS,.03,"E") ;VISIT LOCATION ;M2 20091015
...S DUZ(2)=SAVEDUZ ;M4*ADD*TMM
...I TPBVLOC'=BARVLOC D
....;S TMPREC=TPBVLOC_U_BARVLOC_U_BILLIEN_U_VISIT ;M4*DEL*TMM
....;S TMP=$G(^BARTMP("BARDYSV3",1,"VISIT LOC NO MATCH"))+1 ;M4*DEL*TMM
....;S ^BARTMP("BARDYSV3",1,"VISIT LOC NO MATCH",TMP,0)=TMPREC ;M2 20091015 ;M4*DEL*TMM
....S TMPREC=TPBVLOC_U_BARVLOC_U_BILLIEN_U_VISIT ;M4*ADD*TMM
....S TMP=$G(^BARTMP("BARDYSV3",1,"VISIT LOC NO MATCH"))+1 ;M4*ADD*TMM
....S ^BARTMP("BARDYSV3",1,"VISIT LOC NO MATCH",TMP,0)=TMPREC ;M2 20091015 ;M4*ADD*TMM
...;*** End loc testing
...S IENS=VISIT_","
...S BARVDA=VISIT ;M2
...I BARVDA="" S BARVDA=0 ;M2
...S VISCRDT=$P($$GET1^DIQ(9000010,IENS,.02,"I"),".") ;DATE VISIT CREATED ;M2 20091008
...S BARMY=($E(VISCRDT,1,3)+1700)_"-"_$E(VISCRDT,4,5)
...;S TMP=$G(^AUPNVSIT(VISITIEN,0)) ;M2 20091015 ;M4*DEL*TMM
...S TMP=$G(^AUPNVSIT(VISIT,0)) ;M2 20091015 ;M4*ADD*TMM
...S BARMRG=$P(TMP,"^",37) ;M2 20091015
...S BARVDEL=$$GET1^DIQ(9000010,IENS,.11,"I") ;DELETE FLAG = 1 IF DELETED ;M2 20090930
...S BARDEP=$$GET1^DIQ(9000010,IENS,.09) ;DEPENDENT ENTRY COUNT - IF 0 THE VISIT SHOULD HAVE BEEN DELETED ;M2 20090930
...D BDATA ;get Bill variables ;M2
...D BREC ;Write Bill record ;M2
Q
;
BDATA ;EP - Set 3P Bill data
S IENS=BILLIEN
I TPBDUZ2'="" S BILL3P=$P($G(^ABMDBILL(TPBDUZ2,BILLIEN,0)),U)_" " ;3P BILL NUMBER
I BILL3P'="" S BILLAR=$O(^BARBL(DUZ(2),"B",BILL3P)) ;A/R BILL NUMBER
S BLLARIEN=$G(BARBLIEN)
N D0
S D0=$$GET1^DIQ(90050.01,BLLARIEN_",",3,"I") ;'A/R ACCOUNT' PTR ;M4*DEL*TMM
;S INSTYP=$$GET1^DIQ(9999999.18,INSPTR,.211,"I") ;RETURNS NUM PTR (I.E. 21) P.OTT GET INS TYP
S INSTYP=$$VALI^BARVPM(8) ;$P($G(^AUTTINTY(INSTYP,0)),U,2) ;NUMBER-->"INDIAN PATIENT^I" P.OTT
I INSTYP="I" S ^BARTMP("BARDYSV3",1,"BILLS SCREENED FOR INSTYP=I")=$G(^BARTMP("BARDYSV3",1,"BILLS SCREENED FOR INSTYP=I"))+1
;Use 3PB DUZ2 for 3PB look up
S SAVEDUZ=DUZ(2) ;M4*ADD*TMM
S DUZ(2)=TPBDUZ2 ;M4*ADD*TMM
S BILLSTA=$$GET1^DIQ(9002274.4,IENS,.04,"E") ;BILL STATUS
S BILLNUM=$P($$GET1^DIQ(9002274.4,IENS,.01),"-") ;3P BILL NUMBER
S BILLAPP=$$GET1^DIQ(9002274.4,IENS,.15,"I") ;3P DATE/TIME APPROVED
S BILLAMT=$$GET1^DIQ(9002274.4,IENS,.21) ;3P BILLED AMOUNT
S BILLEXP=$$GET1^DIQ(9002274.4,IENS,.17,"I") ;3P EXPORT NUMBER (DATE EXPORTED TO A/R)
S:BILLEXP'="" BILLEXP=$P($G(^ABMDTXST(DUZ(2),BILLEXP,0)),U) ;INTERNAL FM DATE
S ACTINS=$$GET1^DIQ(9002274.4,IENS,.08,"E") ;ACTIVE INSURER
S DUZ(2)=SAVEDUZ ;M4*ADD*TMM
Q
;
BREC ;EP - BUILD BILL REC
I '$D(^BAROMB($J,BARVLOC,BILLIEN,"BILLREC")) D
.S RECHDR=BARVLOC_U_BILLIEN_U_$S($G(BARMY)'="":BARMY,1:0)
.S BILLREC=RECHDR_U_BILLIEN
.S BILLREC=BILLREC_U_BILLNUM
.S BILLREC=BILLREC_U_BILLAPP
.S BILLREC=BILLREC_U_BILLAMT
.S BILLREC=BILLREC_U_BILLEXP
.S BILLREC=BILLREC_U_ACTINS
.S BILLREC=BILLREC_U_BILLSTA ;M2 20090930
.S BILLREC=BILLREC_U_BARMRG ;M2 20090930
.S BILLREC=BILLREC_U_BARVDEL ;M2 20090930
.S BILLREC=BILLREC_U_BARDEP ;M2 20090930
.S BILLREC=BILLREC_U_MULTVIS ;M2 20091015
.S ^BAROMB($J,BARVLOC,BILLIEN,"BILLREC",BARVDA)="B"_U_BILLREC
.S TMP=$G(^BARTMP("BARDYSV3",$J,"BILLREC"))+1
.S ^BARTMP("BARDYSV3",$J,"BILLREC")=TMP
.S ^BARTMP("BARDYSV3",$J,"BILLREC",TMP)="B"_U_BILLREC
.S ^BARTMP("BARDYSV3",0,20,BARVLOC,"B")=$G(^BARTMP("BARDYSV3",0,20,BARVLOC,"B"))+1
Q
;
INIT ;EP - Initialize
K ^BAROMB($J)
;Kill prior run data
S TMP=$G(^BARTMP("BARDYSV3",0,"JOB"))
I TMP'="" K ^BAROMB(TMP) ;Kill prior run
K ^BARTMP("BARDYSV3")
;Set for this run
S ^BARTMP("BARDYSV3",0,"JOB")=$J
Q ;EOR
BARDYSV3 ; IHS/SD/MAS,TPF - OMB - DAYS TO COLLECTION ; 02/09/2009
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**12,13,14,16,23**;OCT 26, 2005
+2 ;
+3 ; IHS/SD/TMM 07/02/2009 M1 Routine too large. Create 2nd routine ^BARDYSV2
+4 ; IHS/SD/TMM 09/17/2009 M2 Copy BARDYSVZ to BARDYSV3 for OMB Phase II modifications
+5 ; IHS/SD/TMM 01/07/2010 M3 Record XBFLG value returned from ^XBGSAVE
+6 ; IHS/SD/TMM 01/26/2010 M4 Use 3PB DUZ2 for ^DIQ calls TO 3PB files
+7 ; IHS/SD/TMM 01/27/2010 M5 Update BATCH routine with current logic (to match INSTALL^BARDYSV4 and INTERACT)
+8 ; IHS/SD/TMM 01/29/2010 M6 Tag TRANS moved from ^BARDYSV3 to ^BARDYSV5 due to
+9 ; routine size of ^BARDYSV3 and SAC checker requirement
+10 ; MAR 2012 HEAT# 80021 P.OTTIS (=""1M" changed to ["1M")
+11 ; MAR 2012 HEAT# 55217 P.OTTIS Parker - <UNDEFINED>BATCH+36^BARDYSV3
+12 ; FEB 2013 P.OTT CHANGED PTR TO INSURER TYPE
+13 QUIT
+14 ;
+15 ;IT IS EXPECTED THAT IF NO DATES ARE PASSED VIA TASKMAN THAT THE TASK WILL BE SCHEDULED
+16 ;FOR THE FIRST DAY OF THE MONTH AND THE RANGE WILL BE FROM THE 1ST TO THA LAST DAY OF THE
+17 ;MONTH BEFORE
+18 ;
+19 ;ASK DATE RANGE FIND VISITS FOR THAT RANGE IN THE VISIT FILE
INTERACT ;EP - INTERACTIVE EP
+1 IF '$$IHS(DUZ(2))
WRITE !,"THIS REPORT IS NOT INTENDED FOR NON-IHS FACILITIES!!"
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
QUIT
+2 SET ZTQUEUED=$GET(ZTQUEUED)
+3 DO INIT
+4 ;
ASKBEG ;EP - ASK BEGIN DATE
+1 NEW BEGDATE,ENDDATE
+2 KILL DIR
+3 SET DIR(0)="DO^::EX"
+4 SET DIR("A")="Enter Beginning Visit Date"
+5 DO ^DIR
+6 IF $DATA(DIRUT)!$DATA(DTOUT)!($DATA(DUOUT))!(Y="")
QUIT
+7 SET BEGDATE=Y
+8 ;
ASKEND ;EP - ASK END DATE
+1 KILL DIR
+2 SET DIR(0)="DO^::EX"
+3 SET DIR("A")="Enter Ending Visit Date"
+4 DO ^DIR
+5 IF $DATA(DIRUT)!$DATA(DTOUT)!($DATA(DUOUT))!(Y="")
GOTO ASKBEG
+6 SET ENDDATE=Y
+7 IF BEGDATE>ENDDATE
WRITE !,"BEGIN DATE CAN NOT BE GREATER THAN ENDING DATE!"
KILL DIR
SET DIR(0)="E"
DO ^DIR
GOTO ASKEND
+8 DO NOW^%DTC
+9 SET ^BARTMP("BARDYSV3",0,"INTERACT STARTED",DUZ(2),%)=BEGDATE_U_ENDDATE
+10 WRITE !!
+11 DO VISITS^BARDYSV5(BEGDATE,ENDDATE)
+12 ;M2
DO BILLS(BEGDATE,ENDDATE)
+13 ;D TRANS(BEGDATE,ENDDATE) ;M2 ;M6*DEL*TMM
+14 ;M2 ;M6*ADD*TMM
DO TRANS^BARDYSV5(BEGDATE,ENDDATE)
+15 IF '$DATA(^BAROMB($JOB))
Begin DoDot:1
+16 SET BARTMP="NO DATA FOUND FOR OMB REPORT!"
+17 WRITE !,BARTMP
+18 KILL DIR
+19 SET DIR(0)="E"
+20 DO ^DIR
+21 SET ^BARTMP("BARDYSV3",0,"INTERACT COMPLETED",DUZ(2),%)=BARTMP
End DoDot:1
GOTO ASKBEG
+22 SET RC=$$ASKFNAME^BARDYSV4(.BARFILE,BEGDATE,ENDDATE)
+23 WRITE !,"DESTINATION FILE: ",BARFILE
+24 ;M1 BAR*1.8*13 TMM
DO SENDFILE^BARDYSV4("BAROMB(",BARFILE)
+25 DO NOW^%DTC
+26 ;M2
SET ^BARTMP("BARDYSV3",0,"INTERACT COMPLETED",DUZ(2),%)=""
+27 ; Global copy to flat file successful when XBFLG=0
+28 ; XBFLG=0 (zero) Save was successful. No errors detected
+29 ; XBFLG=-1 Save was unsuccessful, If errors detected XBFLG is
+30 ; set to "-1", error info stored in XBFLG(1) and
+31 ; XBGSAVE returns to the calling program WITHOUT SAVING THE
+32 ; FILE.
+33 ; HEAT# 0055217 P.OTT
+34 ;
+35 ;M2 ;M3*ADD*TMM
IF $GET(XBFLG)'=0
SET ^BARTMP("BARDYSV3",0,"INTERACT COMPLETED",DUZ(2),%,1)="Global copy of ^BAROMB Failed"_"^"_$GET(XBFLG)_"^"_$GET(XBFLG(1))
+36 ;M2 ;M3*ADD*TMM
IF $GET(XBFLG)=-1
SET ^BARTMP("BARDYSV3",0,"INTERACT COMPLETED",DUZ(2),%,2)=XBFLG_"^"_$GET(XBFLG(1))
+37 ;M2 ;M3*ADD*TMM
IF $GET(XBFLG)=0
SET ^BARTMP("BARDYSV3",0,"INTERACT COMPLETE",DUZ(2),%,3)="Global copy ^BAROMB successful"
+38 QUIT
+39 ;
+40 ;IT IS EXPECTED THAT IF NO DATES ARE PASSED VIA TASKMAN THAT THE TASK WILL BE SCHEDULED
+41 ;FOR THE FIRST DAY OF THE MONTH AND THE RANGE WILL BE FROM THE 1ST TO THA LAST DAY OF THE
+42 ;MONTH BEFORE
BATCH(BARBEG,BAREND) ;EP - ENTER FOR TASKED JOB
+1 DO INIT
+2 NEW RANGE,BARBEG,BAREND
+3 SET ^BARTMP("BARDYSV3",0,"JOB")=$JOB
+4 ;P.OTT
IF $PIECE(D,U,6)["1M"
SET RANGE=$$LSTMNTH(DT)
SET BARBEG=$PIECE(RANGE,U)
SET BAREND=$PIECE(RANGE,U,2)
+5 IF '$TEST
IF $PIECE(D,U,6)[("D")
SET %DT=""
SET X="T-"_+$PIECE(D,U,6)
DO ^%DT
SET BARBEG=Y
SET BAREND=DT
+6 DO NOW^%DTC
+7 SET ^BARTMP("BARDYSV3",0,"BATCH STARTED",%)=BARBEG_U_BAREND
+8 DO VISITS^BARDYSV5(BARBEG,BAREND)
+9 ;M2
DO BILLS(BARBEG,BAREND)
+10 ;D TRANS(BARBEG,BAREND) ;M2 ;M6*DEL*TMM
+11 ;M2 ;M6*ADD*TMM
DO TRANS^BARDYSV5(BARBEG,BAREND)
+12 SET ^BARTMP("BARDYSV3",0,"BATCH COMPLETED",DUZ(2),%)="OMB PHASE II - Data Extracted, Ready to send"
+13 SET RC=$$ASKFNAME^BARDYSV4(.BARFILE,BARBEG,BAREND)
+14 ;M1 BAR*1.8*13 TMM
DO SENDFILE^BARDYSV4("BAROMB(",BARFILE)
+15 DO NOW^%DTC
+16 ;
+17 ; HEAT# 0055217 P.OTT
+18 ;
+19 ;M2 ;M3*ADD*TMM
IF $GET(XBFLG)'=0
SET ^BARTMP("BARDYSV3",0,"BATCH COMPLETED",DUZ(2),%,1)="Global copy of ^BAROMB Failed"_"^"_$GET(XBFLG)_"^"_$GET(XBFLG(1))
+20 ;M2 ;M3*ADD*TMM
IF $GET(XBFLG)=-1
SET ^BARTMP("BARDYSV3",0,"BATCH COMPLETED",DUZ(2),%,2)=$GET(XBFLG)_"^"_$GET(XBFLG(1))
+21 ;M2 ;M3*ADD*TMM
IF $GET(XBFLG)=0
SET ^BARTMP("BARDYSV3",0,"BATCH COMPLETED",DUZ(2),%,3)="Global copy ^BAROMB successful"
+22 ;*** M5*END ADD*TMM ***
+23 QUIT
+24 ;
+25 ;COMPUTE LAST MONTH'S DAYS IN A MONTH, PASS DT. USE THIS TO GET DATE RANGE
LSTMNTH(TODAY) ;EP - COMPY
+1 NEW DAYS,LSTMNTH,FMYR,STARTDAY,ENDDAY
+2 SET FMYR=$EXTRACT(TODAY,1,3)
+3 SET THISMNTH=$EXTRACT(TODAY,4,5)
+4 SET LSTMNTH=$EXTRACT(TODAY,4,5)-1
+5 IF LSTMNTH=0
SET LSTMNTH=12
+6 SET X=LSTMNTH
+7 SET X1=X
SET X=$SELECT("^1^3^5^7^8^10^12^"[(U_X_U):31,X'=2:30,$EXTRACT(X1,1,3)#4:28,1:29)
+8 SET STARTDAY="01"
+9 SET ENDDAY=X
+10 IF THISMNTH="01"
SET FMYR=FMYR-1
SET LSTMNTH=12
+11 IF $LENGTH(LSTMNTH)=1
SET LSTMNTH="0"_LSTMNTH
+12 SET BEGIN=FMYR_LSTMNTH_STARTDAY
+13 SET END=FMYR_LSTMNTH_ENDDAY
+14 QUIT BEGIN_U_END
+15 ;
IHS(DUZ2) ;EP - RETURN TRUE IF IHS AFFILIATION
+1 NEW REC
+2 SET REC=$ORDER(^AUTTLOC(DUZ2,11,""),-1)
+3 SET AFFIL=$$GET1^DIQ(9999999.0611,REC_","_DUZ2_",",.03,"I")
+4 ;1 MEANS IHS
QUIT AFFIL=1
+5 ;
BILLS(BARBEG,BAREND) ;EP - Find 3P Bills for this period
+1 ;Create sort file for all 3PB's and A/R Bills, then create bill record
+2 ;M2
NEW CNT
+3 SET BEGIN=BARBEG-.01
+4 SET END=BAREND_".999999"
+5 ;
+6 ;Find 3P Bills for this period for all 3PB DUZ(2)
+7 SET TPBDUZ2=0
FOR
SET TPBDUZ2=$ORDER(^ABMDBILL(TPBDUZ2))
IF 'TPBDUZ2
QUIT
Begin DoDot:1
+8 ;3P BILL APPROVE DT/TM
SET TPAPRVDT=BEGIN
FOR CNT=1:1
SET TPAPRVDT=$ORDER(^ABMDBILL(TPBDUZ2,"AP",TPAPRVDT))
IF ('TPAPRVDT)!(TPAPRVDT>END)
QUIT
Begin DoDot:2
+9 ;3P BILL IEN
SET TPBIEN=""
FOR
SET TPBIEN=$ORDER(^ABMDBILL(TPBDUZ2,"AP",TPAPRVDT,TPBIEN))
IF 'TPBIEN
QUIT
Begin DoDot:3
+10 ;3PB IEN noted
SET ^BARTMP("BARDYSV3",10,"BILLS",TPBIEN,0)=TPAPRVDT_U_U_TPBDUZ2
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;
+12 ;Now find A/R Bills for this period
+13 ;M2
NEW CNT
+14 SET TPAPRVDT=BEGIN
FOR CNT=1:1
SET TPAPRVDT=$ORDER(^BARBL(DUZ(2),"AG",TPAPRVDT))
IF ('TPAPRVDT)!(TPAPRVDT>END)
QUIT
Begin DoDot:1
+15 IF '$DATA(ZTQUEUED)&'(CNT#1000)
WRITE "."
+16 SET BARBLIEN=$ORDER(^BARBL(DUZ(2),"AG",TPAPRVDT,""))
IF 'BARBLIEN
QUIT
Begin DoDot:2
+17 SET TPBIEN=$PIECE($GET(^BARBL(DUZ(2),BARBLIEN,0)),U,17)
+18 IF TPBIEN=""
SET TPBIEN=0
+19 ;Update ^BARTMP if doesn't exist from the 3P Bill
+20 SET ^BARTMP("BARDYSV3",10,"BILLS",TPBIEN,BARBLIEN)=TPAPRVDT
+21 IF $DATA(^BARTMP("BARDYSV3",10,"BILLS",TPBIEN,0))
SET $PIECE(^BARTMP("BARDYSV3",10,"BILLS",TPBIEN,0),U,2)="DUP"
End DoDot:2
End DoDot:1
+22 ;
+23 ;$O thru ^BARTMP and create bill records
+24 KILL TMP
+25 SET BILLIEN=""
FOR
SET BILLIEN=$ORDER(^BARTMP("BARDYSV3",10,"BILLS",BILLIEN))
IF BILLIEN=""
QUIT
Begin DoDot:1
+26 SET BARBLIEN=""
FOR
SET BARBLIEN=$ORDER(^BARTMP("BARDYSV3",10,"BILLS",BILLIEN,BARBLIEN))
IF BARBLIEN=""
QUIT
Begin DoDot:2
+27 KILL TMP
+28 IF BARBLIEN=0
Begin DoDot:3
+29 SET TMP=$GET(^BARTMP("BARDYSV3",10,"BILLS",BILLIEN,BARBLIEN))
+30 SET TMP=$PIECE(TMP,U,2)
End DoDot:3
+31 ;skip this one, there will be another entry with same 3PBIEN and a real BARBLIEN
IF $GET(TMP)="DUP"
QUIT
+32 ;Get the 3PB IEN DUZ2
+33 ;TPB DUZ(2)
SET TPBDUZ2=$PIECE($GET(^BARBL(DUZ(2),BARBLIEN,0)),"^",22)
+34 ;
+35 ;Get multiple visits for 3P Bill ;M2 20091015
+36 ;M2 20091015
SET MULTVIS=""
+37 ;PCC VISIT IEN ;M2 20091015
IF TPBDUZ2'=""
SET VISIT=0
FOR TMP=1:1
SET VISIT=$ORDER(^ABMDBILL(TPBDUZ2,BILLIEN,11,VISIT))
IF 'VISIT
QUIT
Begin DoDot:3
+38 ;send all visits for this 3PB
SET $PIECE(MULTVIS,"|",TMP)=VISIT
End DoDot:3
+39 ;M2 20091021 S MULTVIS=$S(MULTVIS["|":MULTVIS,1:"")
+40 ;
+41 ;PCC VISIT IEN ;M2 20091015-moved down here from above
IF TPBDUZ2'=""
SET VISIT=0
FOR
SET VISIT=$ORDER(^ABMDBILL(TPBDUZ2,BILLIEN,11,VISIT))
IF 'VISIT
QUIT
Begin DoDot:3
+42 ;API LOC. OF ENCOUNTER ASUFAC ;M2
SET BARVLOC=$$LOCENC^APCLV(VISIT,"C")
+43 ;M2
IF BARVLOC=""
SET BARVLOC="UNDEF"
+44 ;*** loc testing
+45 ;I BARVLOC="UNDEF" D
+46 ;look at all scenarios initially
+47 SET IENS=BILLIEN
+48 ;M4*ADD*TMM
SET SAVEDUZ=DUZ(2)
+49 ;M4*ADD*TMM
SET DUZ(2)=TPBDUZ2
+50 ;VISIT LOCATION ;M2 20091015
SET TPBVLOC=$$GET1^DIQ(9002274.4,IENS,.03,"E")
+51 ;M4*ADD*TMM
SET DUZ(2)=SAVEDUZ
+52 IF TPBVLOC'=BARVLOC
Begin DoDot:4
+53 ;S TMPREC=TPBVLOC_U_BARVLOC_U_BILLIEN_U_VISIT ;M4*DEL*TMM
+54 ;S TMP=$G(^BARTMP("BARDYSV3",1,"VISIT LOC NO MATCH"))+1 ;M4*DEL*TMM
+55 ;S ^BARTMP("BARDYSV3",1,"VISIT LOC NO MATCH",TMP,0)=TMPREC ;M2 20091015 ;M4*DEL*TMM
+56 ;M4*ADD*TMM
SET TMPREC=TPBVLOC_U_BARVLOC_U_BILLIEN_U_VISIT
+57 ;M4*ADD*TMM
SET TMP=$GET(^BARTMP("BARDYSV3",1,"VISIT LOC NO MATCH"))+1
+58 ;M2 20091015 ;M4*ADD*TMM
SET ^BARTMP("BARDYSV3",1,"VISIT LOC NO MATCH",TMP,0)=TMPREC
End DoDot:4
+59 ;*** End loc testing
+60 SET IENS=VISIT_","
+61 ;M2
SET BARVDA=VISIT
+62 ;M2
IF BARVDA=""
SET BARVDA=0
+63 ;DATE VISIT CREATED ;M2 20091008
SET VISCRDT=$PIECE($$GET1^DIQ(9000010,IENS,.02,"I"),".")
+64 SET BARMY=($EXTRACT(VISCRDT,1,3)+1700)_"-"_$EXTRACT(VISCRDT,4,5)
+65 ;S TMP=$G(^AUPNVSIT(VISITIEN,0)) ;M2 20091015 ;M4*DEL*TMM
+66 ;M2 20091015 ;M4*ADD*TMM
SET TMP=$GET(^AUPNVSIT(VISIT,0))
+67 ;M2 20091015
SET BARMRG=$PIECE(TMP,"^",37)
+68 ;DELETE FLAG = 1 IF DELETED ;M2 20090930
SET BARVDEL=$$GET1^DIQ(9000010,IENS,.11,"I")
+69 ;DEPENDENT ENTRY COUNT - IF 0 THE VISIT SHOULD HAVE BEEN DELETED ;M2 20090930
SET BARDEP=$$GET1^DIQ(9000010,IENS,.09)
+70 ;get Bill variables ;M2
DO BDATA
+71 ;Write Bill record ;M2
DO BREC
End DoDot:3
End DoDot:2
End DoDot:1
+72 QUIT
+73 ;
BDATA ;EP - Set 3P Bill data
+1 SET IENS=BILLIEN
+2 ;3P BILL NUMBER
IF TPBDUZ2'=""
SET BILL3P=$PIECE($GET(^ABMDBILL(TPBDUZ2,BILLIEN,0)),U)_" "
+3 ;A/R BILL NUMBER
IF BILL3P'=""
SET BILLAR=$ORDER(^BARBL(DUZ(2),"B",BILL3P))
+4 SET BLLARIEN=$GET(BARBLIEN)
+5 NEW D0
+6 ;'A/R ACCOUNT' PTR ;M4*DEL*TMM
SET D0=$$GET1^DIQ(90050.01,BLLARIEN_",",3,"I")
+7 ;S INSTYP=$$GET1^DIQ(9999999.18,INSPTR,.211,"I") ;RETURNS NUM PTR (I.E. 21) P.OTT GET INS TYP
+8 ;$P($G(^AUTTINTY(INSTYP,0)),U,2) ;NUMBER-->"INDIAN PATIENT^I" P.OTT
SET INSTYP=$$VALI^BARVPM(8)
+9 IF INSTYP="I"
SET ^BARTMP("BARDYSV3",1,"BILLS SCREENED FOR INSTYP=I")=$GET(^BARTMP("BARDYSV3",1,"BILLS SCREENED FOR INSTYP=I"))+1
+10 ;Use 3PB DUZ2 for 3PB look up
+11 ;M4*ADD*TMM
SET SAVEDUZ=DUZ(2)
+12 ;M4*ADD*TMM
SET DUZ(2)=TPBDUZ2
+13 ;BILL STATUS
SET BILLSTA=$$GET1^DIQ(9002274.4,IENS,.04,"E")
+14 ;3P BILL NUMBER
SET BILLNUM=$PIECE($$GET1^DIQ(9002274.4,IENS,.01),"-")
+15 ;3P DATE/TIME APPROVED
SET BILLAPP=$$GET1^DIQ(9002274.4,IENS,.15,"I")
+16 ;3P BILLED AMOUNT
SET BILLAMT=$$GET1^DIQ(9002274.4,IENS,.21)
+17 ;3P EXPORT NUMBER (DATE EXPORTED TO A/R)
SET BILLEXP=$$GET1^DIQ(9002274.4,IENS,.17,"I")
+18 ;INTERNAL FM DATE
IF BILLEXP'=""
SET BILLEXP=$PIECE($GET(^ABMDTXST(DUZ(2),BILLEXP,0)),U)
+19 ;ACTIVE INSURER
SET ACTINS=$$GET1^DIQ(9002274.4,IENS,.08,"E")
+20 ;M4*ADD*TMM
SET DUZ(2)=SAVEDUZ
+21 QUIT
+22 ;
BREC ;EP - BUILD BILL REC
+1 IF '$DATA(^BAROMB($JOB,BARVLOC,BILLIEN,"BILLREC"))
Begin DoDot:1
+2 SET RECHDR=BARVLOC_U_BILLIEN_U_$SELECT($GET(BARMY)'="":BARMY,1:0)
+3 SET BILLREC=RECHDR_U_BILLIEN
+4 SET BILLREC=BILLREC_U_BILLNUM
+5 SET BILLREC=BILLREC_U_BILLAPP
+6 SET BILLREC=BILLREC_U_BILLAMT
+7 SET BILLREC=BILLREC_U_BILLEXP
+8 SET BILLREC=BILLREC_U_ACTINS
+9 ;M2 20090930
SET BILLREC=BILLREC_U_BILLSTA
+10 ;M2 20090930
SET BILLREC=BILLREC_U_BARMRG
+11 ;M2 20090930
SET BILLREC=BILLREC_U_BARVDEL
+12 ;M2 20090930
SET BILLREC=BILLREC_U_BARDEP
+13 ;M2 20091015
SET BILLREC=BILLREC_U_MULTVIS
+14 SET ^BAROMB($JOB,BARVLOC,BILLIEN,"BILLREC",BARVDA)="B"_U_BILLREC
+15 SET TMP=$GET(^BARTMP("BARDYSV3",$JOB,"BILLREC"))+1
+16 SET ^BARTMP("BARDYSV3",$JOB,"BILLREC")=TMP
+17 SET ^BARTMP("BARDYSV3",$JOB,"BILLREC",TMP)="B"_U_BILLREC
+18 SET ^BARTMP("BARDYSV3",0,20,BARVLOC,"B")=$GET(^BARTMP("BARDYSV3",0,20,BARVLOC,"B"))+1
End DoDot:1
+19 QUIT
+20 ;
INIT ;EP - Initialize
+1 KILL ^BAROMB($JOB)
+2 ;Kill prior run data
+3 SET TMP=$GET(^BARTMP("BARDYSV3",0,"JOB"))
+4 ;Kill prior run
IF TMP'=""
KILL ^BAROMB(TMP)
+5 KILL ^BARTMP("BARDYSV3")
+6 ;Set for this run
+7 SET ^BARTMP("BARDYSV3",0,"JOB")=$JOB
+8 ;EOR
QUIT
