BARDYSVZ ; IHS/SD/MAS,TPF - OMB - DAYS TO COLLECTION REPORT FOR SQL ; 02/09/2009
;;1.8;IHS ACCOUNTS RECEIVABLE;**12,13,23**;OCT 26, 2005
;
; IHS/SD/TMM 07/02/09 M1 Routine too large. Create 2nd routine ^BARDYSV2
; P.OTT FEB 2013 CHANGED PTR TO INSURER TYPE
;
Q
;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
ASKBEG ;EP - ASK BEGIN DATE
K ^XTMP("BARDYSVZ")
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 ^XTMP("BARDYSVZ",$J,"INTERACT STARTED",DUZ(2),%)=BEGDATE_U_ENDDATE
D VISIT(BEGDATE,ENDDATE)
I '$D(^BAROMB($J)) W !,"NO DATA FOUND FOR OMB REPORT!" K DIR S DIR(0)="E" D ^DIR S ^XTMP("BARDYSVZ",$J,"INTERACT COMPLETED",DUZ(2),%)="" G ASKBEG
S RC=$$ASKFNAME(.BARFILE,BEGDATE,ENDDATE)
W !,"DESTINATION FILE: ",BARFILE
D SENDFILE^BARDYSV2("BAROMB(",BARFILE)
D NOW^%DTC
S ^XTMP("BARDYSVZ",$J,"INTERACT COMPLETED",DUZ(2),%)=""
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
N RANGE,BARBEG,BAREND
K ^XTMP("BARDYSVZ")
S ZTQUEUED=1 ;TEST
I $P(D,U,6)="1M" S RANGE=$$LSTMNTH(DT) S BARBEG=$P(RANGE,U),BAREND=$P(RANGE,U,2)
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 ^XTMP("BARDYSVZ",$J,0,"A BATCH STARTED",%)=BARBEG_U_BAREND
N DUZ2
S DUZ2=DUZ(2)
S DUZ(2)=0
F S DUZ(2)=$O(^ABMDPARM(DUZ(2))) Q:'DUZ(2) D
.S ^XTMP("BARDYSVZ",$J,DUZ(2),"FACILITY STARTED",%)=""
.Q:'$$IHS(DUZ(2)) ;NOT INTENDED FOR NON-IHS SITES
.D VISIT(BARBEG,BAREND)
.I '$D(^BAROMB($J)) S ^XTMP("BARDYSVZ",$J,DUZ(2),"FACILITY COMPLETED",%)="NO DATA" Q ;NO DATA FOR THIS DUZ(2) SO DON'T SEND FILE
.S RC=$$ASKFNAME(.BARFILE,BARBEG,BAREND)
.D SENDFILE^BARDYSV2("BAROMB(",BARFILE)
.D NOW^%DTC
.S ^XTMP("BARDYSVZ",$J,DUZ(2),"FACILITY COMPLETED",%)=""
S DUZ(2)=DUZ2
D NOW^%DTC
S ^XTMP("BARDYSVZ",$J,"Z BATCH COMPLETED",%)=""
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
;GIVEN A DATE RANGE FIND VISITS FOR THAT MONTH IN THE VISIT FILE
VISIT(BARBEG,BAREND) ;EP - GET VISIT DATA
K ^BAROMB($J)
N ENTRY
S ENTRY=BARBEG-.01
I $E(BAREND,6,7)="00" S $E(BAREND,6,7)="31"
S BAREND=BAREND_".24"
S BAROMY=$E(BARBEG,2,5)
S BARYR=$E(DT,1,3)
D NOW^%DTC
F S ENTRY=$O(^AUPNVSIT("B",ENTRY)) Q:ENTRY=""!(ENTRY>BAREND) D
.S BARMY=($E(ENTRY,1,3)+1700)_"-"_$E(ENTRY,4,5)
.S BARVDA=$$GETV(ENTRY) ;Get Visit data
.Q:'BARVDA ;Excluded or no visit
.D GETB(BARVDA) ;Get bill(s) and set into file
Q
;
GETV(ENTRY) ;
N VISITIEN,BARVDA,CNT
S (BARVDA,VISITIEN)=""
F CNT=1:1 S VISITIEN=$O(^AUPNVSIT("B",ENTRY,VISITIEN)) Q:'VISITIEN D
.W:'$D(ZTQUEUED)&'(CNT#1000) "."
.S IENS=VISITIEN_","
.S BARSCAT=$$SC^APCLV(VISITIEN,"I") ;API SERVICE CATEGORY
.I "^A^D^H^O^I^S^R^T^"'[(U_BARSCAT_U) S BARVDA=0 Q ;DO NOT INCLUDE CATEGORIES LISTED IN WO D164 ITEM B),3
.; C=CHART REVIEW,N=NOT FOUND,E=EVENT (HISTORICAL),X=ANCILLARY
.S BARSCAT=$$SC^APCLV(VISITIEN,"E") ;API SERVICE CATEGORY
.S BARMRG=$$GET1^DIQ(9000010,IENS,.37) ;MERGED TO
.I BARMRG'="" S BARVDA=0 Q ;DO NOT INCLUDE MERGED VISITS
.S VSITCRET=$P($$GET1^DIQ(9000010,IENS,.02,"I"),".") ;DATE VISIT CREATED
.S BARVADMT=$P($$GET1^DIQ(9000010,IENS,.01,"I"),".") ;VISIT/ADMIT DATE&TIME
.;DETERMINE REVIEW DATE
.S VPCCREV=$P($$GET1^DIQ(9000010,IENS,.13,"I"),".") ;DATE LAST MODIFIED
.S PCCREV=$$GEREV(VISITIEN,VPCCREV) ;CHECK ALGORYTHM ;
.;END REVIEW DATE
.S BARVTYP=$$GET1^DIQ(9000010,IENS,.03,"E") ;TYPE (OF VISIT)
.S BARVLOC=$$LOCENC^APCLV(VISITIEN,"C") ;API LOC. OF ENCOUNTER ASUFAC
.S BARLOCN=$$GET1^DIQ(9000010,IENS,.06,"E") ;'LOC. OF ENCOUNTER' NAME
.S:BARVLOC="" BARVLOC="UNDEF"
.S BARVDEL=$$GET1^DIQ(9000010,IENS,.11,"I") ;DELETE FLAG = 1 IF DELETED
.S BARDEP=$$GET1^DIQ(9000010,IENS,.09) ;DEPENDENT ENTRY COUNT - IF 0 THE VISIT SHOULD HAVE BEEN DELETED
.I 'BARDEP S BARVDA=0 Q ;IF DELETE FLAG COMMENT IS TRUE THIS MAY BE TRUE
.S BARTPBF=$$GET1^DIQ(9000010,IENS,.04,"E") ;THIRD PARTY BILLED (Visit has been billed)
.S BARCS=$$CLINIC^APCLV(VISITIEN,"C") ;CLINIC STOP (FOR
.I BARCS="" S BARVDA=0 Q ;IF NO CLINIC, NO BILL SO DO NOT INCLUDE. INCLUDE PER MARSHA
.S BARVDA=VISITIEN
Q BARVDA
;
;BARVDA= VISIT DA
GETB(BARVDA) ;EP - GET BILL DATA
N BILLIEN,BARBIL,IENS,BILLSTA,BILLNUM,INSPTR,INSTYP
S (BARBIL,BILLIEN)=""
F S BILLIEN=$O(^ABMDBILL(DUZ(2),"AV",BARVDA,BILLIEN)) Q:'BILLIEN D
.S IENS=BILLIEN_","
.S BILL3P=$P($G(^ABMDBILL(DUZ(2),BILLIEN,0)),U)_" "
.S BILLAR=$O(^BARBL(DUZ(2),"B",BILL3P))
.S:BILLAR'="" BLLARIEN=$O(^BARBL(DUZ(2),"B",BILLAR,""))
.Q:'$G(BLLARIEN) ;CAN'T FIND CORRESPONDING A/R BILL
.S INSPTR=$$GET1^DIQ(90050.03,BLLARIEN_",",6,"I") ;'A/R ACCOUNT' PTR
.S INSTYP=$$GET1^DIQ(9999999.18,INSPTR,.211,"I") ;RETURNS NUM PTR (I.E. 21) P.OTT GET INS TYP
.S ISNTYP=$P($G(^AUTTINTY(BARALLC,0)),U,2) ;NUMBER-->"INDIAN PATIENT^I" P.OTT
.I INSTYP="I" S ^XTMP("BARDYSVZ","BILLS SCREENED FOR INSTYP=I")=$G(^XTMP("BARDYSVZ","BILLS SCREENED FOR INSTYP=I"))+1
.Q:INSTYP="I" ;DO NOT INCLUDE 'INDIAN PATIENT' BILLS PER MEETING 4/7/2009
.S BILLSTA=$$GET1^DIQ(9002274.4,IENS,.04,"E") ;BILL STATUS
.S:BILLSTA="" BILLSTA="UNDEF"
.;'R' FOR REVIEWED;
.;'A' FOR APPROVED;
.;'B' FOR BILLED;
.;'T' FOR TRANSFERRED TO FINANCE;
.;'C' FOR COMPLETED;
.;'P' FOR PARTIAL PAYMENT;
.;'X' FOR CANCELLED;
.Q:BILLSTA="X" ;IF BILL WAS CANCELLED NO PAYMENT IS EXPECTED THEREFORE DO NOT INCLUDE.
.S BILLNUM=$P($$GET1^DIQ(9002274.4,IENS,.01),"-") ;BILL NUMBER
.S BILLAPP=$$GET1^DIQ(9002274.4,IENS,.15,"I") ;DATE/TIME APPROVED
.S BILLAMT=$$GET1^DIQ(9002274.4,IENS,.21) ;BILLED AMOUNT
.S BILLEXP=$$GET1^DIQ(9002274.4,IENS,.17,"I") ;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
.D SETBILL ;SET TMP GLOBAL SORT BY BILL
.;
.D GETTX(BILLIEN) ;Get transactions, if any
.Q
Q
;
GETTX(BILLIEN) ;EP - GET TRANSACTION DATA
;BILLIEN IS TPB IEN
N TRANDATE,INSURER,TRANTYPE,ADJCAT,ADJTYP,IENS,RECHDR,ARBILL,BLLARIEN,INSTYP
S BILL3P=$P($G(^ABMDBILL(DUZ(2),BILLIEN,0)),U)_" "
S BILLAR=$O(^BARBL(DUZ(2),"B",BILL3P))
S:BILLAR'="" BLLARIEN=$O(^BARBL(DUZ(2),"B",BILLAR,""))
Q:'$G(BLLARIEN) ;CAN'T FIND CORRESPONDING A/R BILL
;
S RECHDR=BARVLOC_U_BILLIEN_U_BARMY
S TRANDATE=""
F S TRANDATE=$O(^BARTR(DUZ(2),"AC",BLLARIEN,TRANDATE)) Q:TRANDATE="" D
.S IENS=TRANDATE_","
.I $$GET1^DIQ(90050.03,IENS,7,"I")="Y" Q ;'MESSAGE' IF YES SCREEN OUT PER MEETING 4/7/2009
.S INSURER=$$GET1^DIQ(90050.03,IENS,6,"E") ;'A/R ACCOUNT'
.S INSPTR=$$GET1^DIQ(90050.03,IENS,6,"I") ;'A/R ACCOUNT' PTR
.S TRANTYP=$$GET1^DIQ(90050.03,IENS,101,"E") ;'TRANSACTION TYPE'
.S CREDDEB=$$GET1^DIQ(90050.03,IENS,3.5,"I") ;'CREDIT / DEBIT'
.S ADJCAT=$$GET1^DIQ(90050.03,IENS,102,"E") ;'ADJUSTMENT CATEGORY'
.S ADJTYP=$$GET1^DIQ(90050.03,IENS,103,"E") ;'ADJUSTMENT TYPE'
.S ARBILL=$$GET1^DIQ(90050.03,IENS,4,"I") ;'PTR TO A/R BILL'
.S CURAMT=$$GET1^DIQ(90050.01,ARBILL_",",15,"I") ;'CURRENT BILL' AMOUNT IN 'A/R BILL'
.S INSTYP=$$GET1^DIQ(9999999.18,INSPTR,.211,"I") ;RETURNS NUM PTR (I.E. 21) P.OTT GET INS TYP
.S ISNTYP=$P($G(^AUTTINTY(BARALLC,0)),U,2) ;NUMBER-->"INDIAN PATIENT^I" P.OTT
.I INSTYP="I" S ^XTMP("BARDYSVZ","TXS SCREENED FOR INSTYP=I")=$G(^XTMP("BARDYSVZ","TXS SCREENED FOR INSTYP=I"))+1
.Q:INSTYP="I" ;DO NOT INCLUDE 'INDIAN PATIENT' BILLS PER MEETING 4/7/2009
.I '$D(^BAROMB($J,BARVLOC,BARVDA,"TRANS REC",TRANDATE)) D
..S TRANREC="T"_U_RECHDR_U_TRANDATE_U_INSURER_U_TRANTYP_U_$P(TRANDATE,".")_U_CREDDEB_U_ADJCAT_U_ADJTYP_U_CURAMT_U_INSTYP
..S ^BAROMB($J,BARVLOC,BILLIEN,"TRANS REC",TRANDATE)=TRANREC
Q
;
GEREV(BARVDA,VPCCREV) ;EP - GET LAST DATE 'REVIEWED'
;PER DAVID BATTESE GET REVIEW DATE FROM V CHART AUDIT IF TURNED ON
N TMP,QUEAUDIT,EARLIEST
S QUEAUDIT=$$GET1^DIQ(9001000,DUZ(2)_",",.12,"I") ;FIELD 'EHR/CHART AUDIT START DATE' FROM 'PCC MASTER CONTROL'
Q:BARVADMT<QUEAUDIT VPCCREV ;IF ADMIT DATE IS BEFORE AUDIT WAS TURNED ON GET REVIEW DATE FROM 'DATE LAST MODIFIED'
D ;OTHERWISE SEE IF YOU CAN GET IT IN THE 'V CHART AUDIT' FILE
.S (PCCREV,TMP)="" ;^AUPNVCA = V CHART AUDIT
.F S TMP=$O(^AUPNVCA("AD",BARVDA,TMP)) Q:'TMP D
..I $$GET1^DIQ(9000010.45,TMP_",",.04)="R" D ;CHART AUDIT STATUS, R=REVIEWED/COMPLETE I=INCOMPLETE
...S PCCREV=$$GET1^DIQ(9000010.45,BARVDA_",",.01) ;DATE OF AUDIT
I PCCREV S PCCREV=PCCREV_"A" ;IF A "R" DATE OF AUDIT WAS FOUND THEN USE IT
E S PCCREV=VPCCREV_"V" ;OTHERWISE STAY WITH THE 'DATE LAST MODIFIED'
Q PCCREV
;
SETVISIT ;EP - SET THE VISIT AND BILL RECORDS SORTED BY VISIT
N VISITREC,BILLREC,RECHDR,TRANREC
S (BILLREC,VISITREC)=""
S RECHDR=BARVLOC_U_BARVDA_U_BARMY
;
I '$D(^BAROMB($J,BARVLOC,BARVDA,"A VISITREC")) D
.S VISITREC=RECHDR_U_BARSCAT ;'SERVICE CATEGORY'
.S VISITREC=VISITREC_U_BARVTYP ;'VISIT TYPE'
.S VISITREC=VISITREC_U_$G(VSITCRET) ;'DATE VISIT CREATED'
.S VISITREC=VISITREC_U_$G(BARVADMT) ;'VISIT/ADMIT DATE&TIME'
.S VISITREC=VISITREC_U_$G(PCCREV) ;"VISIT REVIEWED DATE" SEE $$GETREV
.S VISITREC=VISITREC_U_BARLOCN ;'LOC. OF ENCOUNTER' - NAME
.S ^BAROMB($J,BARVLOC,BARVDA,"A VISITREC")="V"_U_VISITREC
;
;
I '$D(^BAROMB($J,BARVLOC,BARVDA,"BILLREC",BILLIEN)) D
.S BILLREC=RECHDR_U_BILLIEN
.S BILLREC=BILLREC_U_BILLNUM_U_BILLAPP_U_BILLAMT_U_BILLEXP_U_ACTINS
.S ^BAROMB($J,BARVLOC,BARVDA,"BILLREC",BILLIEN)="B"_U_BILLREC
Q
;
SETBILL ;EP - SET THE VISIT AND BILL RECORDS SORTED BY BILL
N VISITREC,BILLREC,RECHDR,TRANREC
S (BILLREC,VISITREC)=""
S RECHDR=BARVLOC_U_BILLIEN_U_BARMY
;
I '$D(^BAROMB($J,BARVLOC,BILLIEN,"BILLREC")) D
.S BILLREC=RECHDR_U_BILLIEN
.S BILLREC=BILLREC_U_BILLNUM_U_BILLAPP_U_BILLAMT_U_BILLEXP_U_ACTINS
.S ^BAROMB($J,BARVLOC,BILLIEN,"BILLREC",BARVDA)="B"_U_BILLREC
;
;
I '$D(^BAROMB($J,BARVLOC,BILLIEN,"Q VISITREC",BARVDA)) D
.S VISITREC=RECHDR_U_BARVDA ;VISIT IEN
.S VISITREC=VISITREC_U_BARSCAT ;'SERVICE CATEGORY'
.S VISITREC=VISITREC_U_BARVTYP ;'VISIT TYPE'
.S VISITREC=VISITREC_U_$G(VSITCRET) ;'DATE VISIT CREATED'
.S VISITREC=VISITREC_U_$G(BARVADMT) ;'VISIT/ADMIT DATE&TIME'
.S VISITREC=VISITREC_U_$G(PCCREV) ;"VISIT REVIEWED DATE" SEE $$GETREV
.S VISITREC=VISITREC_U_BARLOCN ;'LOC. OF ENCOUNTER' - NAME
.S ^BAROMB($J,BARVLOC,BILLIEN,"Q VISITREC",BARVDA)="V"_U_VISITREC
Q
;
;
ASKFNAME(BARFILE,BEGDATE,ENDDATE) ;EP - ASK FOR FILENAME (COPIED FROM BARUFUT1)
S BARFILE=$$GETFILNM(BEGDATE,ENDDATE)
W !!,"File will be created using the following name: ",BARFILE
Q 1
;
GETFILNM(BEGDATE,ENDDATE) ;EP - CREATE FILE NAME (COPIED FROM BARUFUT1)
N FNROOT,FNEXT,FN,YR,DATE,TIME,DATETIME,BARPK,BARPT,BARP2,BARP3,DATERANG
S FNROOT="IHS_AR_OMB_"_DUZ_"_"_$$GETSUFAC()
S FNXREF=DUZ_"_"_$$GETSUFAC()
S BARV=$$VERSION^XPDUTL("BAR")
S BARP2=$$FILLSTR^BARUFUT1($P(BARV,".",2),2,"R","0")
S BARPK=$O(^DIC(9.4,"C","BAR",0))
S BARPK="IHS ACCOUNTS RECEIVABLE"
S BARPT=$$LAST^XPDUTL(BARPK,BARV)
S BARP3=$$FILLSTR^BARUFUT1(+BARPT,2,"R","0")
S FNXT=$P(BARV,".",1)_"."_BARP2_"."_BARP3
S FNEXT="_"_FNXT_".DAT"
S FN=FNROOT
GETFILAG ;CHECK FOR FILE NAME ALREADY USED (COPIED FROM BARUFUT1)
D NOW^%DTC
S YR=1700+$E(%,1,3)
S DATE=YR_$E(%,4,7)
S Y=% X ^DD("DD")
S TIME=$TR($P(Y,"@",2),":")
S:$L(TIME)=4 TIME=TIME_"00"
S DATETIME=DATE_"_"_TIME
S DATERANG="-"_BEGDATE_"-"_ENDDATE_"-"
S FN=FNROOT_"_"_DATETIME_DATERANG
S FN=FN_FNEXT
Q FN
;
GETSUFAC() ;EP;GIVEN DUZ(2) (COPIED FROM BARUFUT1)
; get parent from parent/satellite file
N BARSAT,BARPAR,DA,ASUFAC
S BARSAT=DUZ(2)
S BARPAR=0 ; Parent
; check site active at DOS to ensure bill added to correct site
S DA=0
F S DA=$O(^BAR(90052.06,DA)) Q:DA'>0 D Q:BARPAR
. Q:'$D(^BAR(90052.06,DA,DA)) ; Pos Parent UNDEF Site Parameter
. Q:'$D(^BAR(90052.05,DA,BARSAT)) ; Satellite UNDEF Parent/Satellit
. Q:+$P($G(^BAR(90052.05,DA,BARSAT,0)),U,5) ; Par/Sat not usable
. ; Q if sat NOT active at DT
. I DT<$P($G(^BAR(90052.05,DA,BARSAT,0)),U,6) Q
. ; Q if sat became NOT active before DT
. I $P($G(^BAR(90052.05,DA,BARSAT,0)),U,7),(DT>$P($G(^BAR(90052.05,DA,BARSAT,0)),U,7)) Q
. S BARPAR=$S(BARSAT:$P($G(^BAR(90052.05,DA,BARSAT,0)),U,3),1:"")
S ASUFAC=$$CURASUFC(BARPAR,DT)
Q ASUFAC
;
CURASUFC(LOCIEN,BARDOS) ;EP - GET CURRENT ASUFAC BASED ON 'DOS BEGIN' (#102) IN A/R BILL FILE (COPIED FROM BARUFUT1)
Q:LOCIEN="" "UNPOPL"
Q:BARDOS="" "UNPOPD"
N ASUFAC,BARDT,BARDTFLG
S ASUFAC=""
S BARDT=0
S BARDTFLG=0
S ASUFAC=$$GET1^DIQ(9999999.06,DUZ(2)_",",.12) ;First take it from 'asufac index" field
;if not, check class multiple
I 'ASUFAC D
.F S BARDT=$O(^AUTTLOC(LOCIEN,11,BARDT)) Q:BARDT=""!(BARDTFLG=1) D
..I BARDOS>$P($G(^AUTTLOC(LOCIEN,11,BARDT,0)),U) D
...S ASUFAC=$P($G(^AUTTLOC(LOCIEN,11,BARDT,0)),U,6)
...S BARDTFLG=1
;S:ASUFAC="" ASUFAC=$$GET1^DIQ(9999999.06,DUZ(2)_",",.12)
Q ASUFAC
;
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
BARDYSVZ ; IHS/SD/MAS,TPF - OMB - DAYS TO COLLECTION REPORT FOR SQL ; 02/09/2009
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**12,13,23**;OCT 26, 2005
+2 ;
+3 ; IHS/SD/TMM 07/02/09 M1 Routine too large. Create 2nd routine ^BARDYSV2
+4 ; P.OTT FEB 2013 CHANGED PTR TO INSURER TYPE
+5 ;
+6 QUIT
+7 ;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
ASKBEG ;EP - ASK BEGIN DATE
+1 KILL ^XTMP("BARDYSVZ")
+2 NEW BEGDATE,ENDDATE
+3 KILL DIR
+4 SET DIR(0)="DO^::EX"
+5 SET DIR("A")="Enter Beginning Visit Date"
+6 DO ^DIR
+7 IF $DATA(DIRUT)!$DATA(DTOUT)!($DATA(DUOUT))!(Y="")
QUIT
+8 SET BEGDATE=Y
+9 ;
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 ^XTMP("BARDYSVZ",$JOB,"INTERACT STARTED",DUZ(2),%)=BEGDATE_U_ENDDATE
+10 DO VISIT(BEGDATE,ENDDATE)
+11 IF '$DATA(^BAROMB($JOB))
WRITE !,"NO DATA FOUND FOR OMB REPORT!"
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET ^XTMP("BARDYSVZ",$JOB,"INTERACT COMPLETED",DUZ(2),%)=""
GOTO ASKBEG
+12 SET RC=$$ASKFNAME(.BARFILE,BEGDATE,ENDDATE)
+13 WRITE !,"DESTINATION FILE: ",BARFILE
+14 DO SENDFILE^BARDYSV2("BAROMB(",BARFILE)
+15 DO NOW^%DTC
+16 SET ^XTMP("BARDYSVZ",$JOB,"INTERACT COMPLETED",DUZ(2),%)=""
+17 QUIT
+18 ;
+19 ;IT IS EXPECTED THAT IF NO DATES ARE PASSED VIA TASKMAN THAT THE TASK WILL BE SCHEDULED
+20 ;FOR THE FIRST DAY OF THE MONTH AND THE RANGE WILL BE FROM THE 1ST TO THA LAST DAY OF THE
+21 ;MONTH BEFORE
BATCH(BARBEG,BAREND) ;EP - ENTER FOR TASKED JOB
+1 NEW RANGE,BARBEG,BAREND
+2 KILL ^XTMP("BARDYSVZ")
+3 ;TEST
SET ZTQUEUED=1
+4 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 ^XTMP("BARDYSVZ",$JOB,0,"A BATCH STARTED",%)=BARBEG_U_BAREND
+8 NEW DUZ2
+9 SET DUZ2=DUZ(2)
+10 SET DUZ(2)=0
+11 FOR
SET DUZ(2)=$ORDER(^ABMDPARM(DUZ(2)))
IF 'DUZ(2)
QUIT
Begin DoDot:1
+12 SET ^XTMP("BARDYSVZ",$JOB,DUZ(2),"FACILITY STARTED",%)=""
+13 ;NOT INTENDED FOR NON-IHS SITES
IF '$$IHS(DUZ(2))
QUIT
+14 DO VISIT(BARBEG,BAREND)
+15 ;NO DATA FOR THIS DUZ(2) SO DON'T SEND FILE
IF '$DATA(^BAROMB($JOB))
SET ^XTMP("BARDYSVZ",$JOB,DUZ(2),"FACILITY COMPLETED",%)="NO DATA"
QUIT
+16 SET RC=$$ASKFNAME(.BARFILE,BARBEG,BAREND)
+17 DO SENDFILE^BARDYSV2("BAROMB(",BARFILE)
+18 DO NOW^%DTC
+19 SET ^XTMP("BARDYSVZ",$JOB,DUZ(2),"FACILITY COMPLETED",%)=""
End DoDot:1
+20 SET DUZ(2)=DUZ2
+21 DO NOW^%DTC
+22 SET ^XTMP("BARDYSVZ",$JOB,"Z BATCH COMPLETED",%)=""
+23 QUIT
+24 ;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 ;GIVEN A DATE RANGE FIND VISITS FOR THAT MONTH IN THE VISIT FILE
VISIT(BARBEG,BAREND) ;EP - GET VISIT DATA
+1 KILL ^BAROMB($JOB)
+2 NEW ENTRY
+3 SET ENTRY=BARBEG-.01
+4 IF $EXTRACT(BAREND,6,7)="00"
SET $EXTRACT(BAREND,6,7)="31"
+5 SET BAREND=BAREND_".24"
+6 SET BAROMY=$EXTRACT(BARBEG,2,5)
+7 SET BARYR=$EXTRACT(DT,1,3)
+8 DO NOW^%DTC
+9 FOR
SET ENTRY=$ORDER(^AUPNVSIT("B",ENTRY))
IF ENTRY=""!(ENTRY>BAREND)
QUIT
Begin DoDot:1
+10 SET BARMY=($EXTRACT(ENTRY,1,3)+1700)_"-"_$EXTRACT(ENTRY,4,5)
+11 ;Get Visit data
SET BARVDA=$$GETV(ENTRY)
+12 ;Excluded or no visit
IF 'BARVDA
QUIT
+13 ;Get bill(s) and set into file
DO GETB(BARVDA)
End DoDot:1
+14 QUIT
+15 ;
GETV(ENTRY) ;
+1 NEW VISITIEN,BARVDA,CNT
+2 SET (BARVDA,VISITIEN)=""
+3 FOR CNT=1:1
SET VISITIEN=$ORDER(^AUPNVSIT("B",ENTRY,VISITIEN))
IF 'VISITIEN
QUIT
Begin DoDot:1
+4 IF '$DATA(ZTQUEUED)&'(CNT#1000)
WRITE "."
+5 SET IENS=VISITIEN_","
+6 ;API SERVICE CATEGORY
SET BARSCAT=$$SC^APCLV(VISITIEN,"I")
+7 ;DO NOT INCLUDE CATEGORIES LISTED IN WO D164 ITEM B),3
IF "^A^D^H^O^I^S^R^T^"'[(U_BARSCAT_U)
SET BARVDA=0
QUIT
+8 ; C=CHART REVIEW,N=NOT FOUND,E=EVENT (HISTORICAL),X=ANCILLARY
+9 ;API SERVICE CATEGORY
SET BARSCAT=$$SC^APCLV(VISITIEN,"E")
+10 ;MERGED TO
SET BARMRG=$$GET1^DIQ(9000010,IENS,.37)
+11 ;DO NOT INCLUDE MERGED VISITS
IF BARMRG'=""
SET BARVDA=0
QUIT
+12 ;DATE VISIT CREATED
SET VSITCRET=$PIECE($$GET1^DIQ(9000010,IENS,.02,"I"),".")
+13 ;VISIT/ADMIT DATE&TIME
SET BARVADMT=$PIECE($$GET1^DIQ(9000010,IENS,.01,"I"),".")
+14 ;DETERMINE REVIEW DATE
+15 ;DATE LAST MODIFIED
SET VPCCREV=$PIECE($$GET1^DIQ(9000010,IENS,.13,"I"),".")
+16 ;CHECK ALGORYTHM ;
SET PCCREV=$$GEREV(VISITIEN,VPCCREV)
+17 ;END REVIEW DATE
+18 ;TYPE (OF VISIT)
SET BARVTYP=$$GET1^DIQ(9000010,IENS,.03,"E")
+19 ;API LOC. OF ENCOUNTER ASUFAC
SET BARVLOC=$$LOCENC^APCLV(VISITIEN,"C")
+20 ;'LOC. OF ENCOUNTER' NAME
SET BARLOCN=$$GET1^DIQ(9000010,IENS,.06,"E")
+21 IF BARVLOC=""
SET BARVLOC="UNDEF"
+22 ;DELETE FLAG = 1 IF DELETED
SET BARVDEL=$$GET1^DIQ(9000010,IENS,.11,"I")
+23 ;DEPENDENT ENTRY COUNT - IF 0 THE VISIT SHOULD HAVE BEEN DELETED
SET BARDEP=$$GET1^DIQ(9000010,IENS,.09)
+24 ;IF DELETE FLAG COMMENT IS TRUE THIS MAY BE TRUE
IF 'BARDEP
SET BARVDA=0
QUIT
+25 ;THIRD PARTY BILLED (Visit has been billed)
SET BARTPBF=$$GET1^DIQ(9000010,IENS,.04,"E")
+26 ;CLINIC STOP (FOR
SET BARCS=$$CLINIC^APCLV(VISITIEN,"C")
+27 ;IF NO CLINIC, NO BILL SO DO NOT INCLUDE. INCLUDE PER MARSHA
IF BARCS=""
SET BARVDA=0
QUIT
+28 SET BARVDA=VISITIEN
End DoDot:1
+29 QUIT BARVDA
+30 ;
+31 ;BARVDA= VISIT DA
GETB(BARVDA) ;EP - GET BILL DATA
+1 NEW BILLIEN,BARBIL,IENS,BILLSTA,BILLNUM,INSPTR,INSTYP
+2 SET (BARBIL,BILLIEN)=""
+3 FOR
SET BILLIEN=$ORDER(^ABMDBILL(DUZ(2),"AV",BARVDA,BILLIEN))
IF 'BILLIEN
QUIT
Begin DoDot:1
+4 SET IENS=BILLIEN_","
+5 SET BILL3P=$PIECE($GET(^ABMDBILL(DUZ(2),BILLIEN,0)),U)_" "
+6 SET BILLAR=$ORDER(^BARBL(DUZ(2),"B",BILL3P))
+7 IF BILLAR'=""
SET BLLARIEN=$ORDER(^BARBL(DUZ(2),"B",BILLAR,""))
+8 ;CAN'T FIND CORRESPONDING A/R BILL
IF '$GET(BLLARIEN)
QUIT
+9 ;'A/R ACCOUNT' PTR
SET INSPTR=$$GET1^DIQ(90050.03,BLLARIEN_",",6,"I")
+10 ;RETURNS NUM PTR (I.E. 21) P.OTT GET INS TYP
SET INSTYP=$$GET1^DIQ(9999999.18,INSPTR,.211,"I")
+11 ;NUMBER-->"INDIAN PATIENT^I" P.OTT
SET ISNTYP=$PIECE($GET(^AUTTINTY(BARALLC,0)),U,2)
+12 IF INSTYP="I"
SET ^XTMP("BARDYSVZ","BILLS SCREENED FOR INSTYP=I")=$GET(^XTMP("BARDYSVZ","BILLS SCREENED FOR INSTYP=I"))+1
+13 ;DO NOT INCLUDE 'INDIAN PATIENT' BILLS PER MEETING 4/7/2009
IF INSTYP="I"
QUIT
+14 ;BILL STATUS
SET BILLSTA=$$GET1^DIQ(9002274.4,IENS,.04,"E")
+15 IF BILLSTA=""
SET BILLSTA="UNDEF"
+16 ;'R' FOR REVIEWED;
+17 ;'A' FOR APPROVED;
+18 ;'B' FOR BILLED;
+19 ;'T' FOR TRANSFERRED TO FINANCE;
+20 ;'C' FOR COMPLETED;
+21 ;'P' FOR PARTIAL PAYMENT;
+22 ;'X' FOR CANCELLED;
+23 ;IF BILL WAS CANCELLED NO PAYMENT IS EXPECTED THEREFORE DO NOT INCLUDE.
IF BILLSTA="X"
QUIT
+24 ;BILL NUMBER
SET BILLNUM=$PIECE($$GET1^DIQ(9002274.4,IENS,.01),"-")
+25 ;DATE/TIME APPROVED
SET BILLAPP=$$GET1^DIQ(9002274.4,IENS,.15,"I")
+26 ;BILLED AMOUNT
SET BILLAMT=$$GET1^DIQ(9002274.4,IENS,.21)
+27 ;EXPORT NUMBER (DATE EXPORTED TO A/R)
SET BILLEXP=$$GET1^DIQ(9002274.4,IENS,.17,"I")
+28 ;INTERNAL fm DATE
IF BILLEXP'=""
SET BILLEXP=$PIECE($GET(^ABMDTXST(DUZ(2),BILLEXP,0)),U)
+29 ;ACTIVE INSURER
SET ACTINS=$$GET1^DIQ(9002274.4,IENS,.08,"E")
+30 ;SET TMP GLOBAL SORT BY BILL
DO SETBILL
+31 ;
+32 ;Get transactions, if any
DO GETTX(BILLIEN)
+33 QUIT
End DoDot:1
+34 QUIT
+35 ;
GETTX(BILLIEN) ;EP - GET TRANSACTION DATA
+1 ;BILLIEN IS TPB IEN
+2 NEW TRANDATE,INSURER,TRANTYPE,ADJCAT,ADJTYP,IENS,RECHDR,ARBILL,BLLARIEN,INSTYP
+3 SET BILL3P=$PIECE($GET(^ABMDBILL(DUZ(2),BILLIEN,0)),U)_" "
+4 SET BILLAR=$ORDER(^BARBL(DUZ(2),"B",BILL3P))
+5 IF BILLAR'=""
SET BLLARIEN=$ORDER(^BARBL(DUZ(2),"B",BILLAR,""))
+6 ;CAN'T FIND CORRESPONDING A/R BILL
IF '$GET(BLLARIEN)
QUIT
+7 ;
+8 SET RECHDR=BARVLOC_U_BILLIEN_U_BARMY
+9 SET TRANDATE=""
+10 FOR
SET TRANDATE=$ORDER(^BARTR(DUZ(2),"AC",BLLARIEN,TRANDATE))
IF TRANDATE=""
QUIT
Begin DoDot:1
+11 SET IENS=TRANDATE_","
+12 ;'MESSAGE' IF YES SCREEN OUT PER MEETING 4/7/2009
IF $$GET1^DIQ(90050.03,IENS,7,"I")="Y"
QUIT
+13 ;'A/R ACCOUNT'
SET INSURER=$$GET1^DIQ(90050.03,IENS,6,"E")
+14 ;'A/R ACCOUNT' PTR
SET INSPTR=$$GET1^DIQ(90050.03,IENS,6,"I")
+15 ;'TRANSACTION TYPE'
SET TRANTYP=$$GET1^DIQ(90050.03,IENS,101,"E")
+16 ;'CREDIT / DEBIT'
SET CREDDEB=$$GET1^DIQ(90050.03,IENS,3.5,"I")
+17 ;'ADJUSTMENT CATEGORY'
SET ADJCAT=$$GET1^DIQ(90050.03,IENS,102,"E")
+18 ;'ADJUSTMENT TYPE'
SET ADJTYP=$$GET1^DIQ(90050.03,IENS,103,"E")
+19 ;'PTR TO A/R BILL'
SET ARBILL=$$GET1^DIQ(90050.03,IENS,4,"I")
+20 ;'CURRENT BILL' AMOUNT IN 'A/R BILL'
SET CURAMT=$$GET1^DIQ(90050.01,ARBILL_",",15,"I")
+21 ;RETURNS NUM PTR (I.E. 21) P.OTT GET INS TYP
SET INSTYP=$$GET1^DIQ(9999999.18,INSPTR,.211,"I")
+22 ;NUMBER-->"INDIAN PATIENT^I" P.OTT
SET ISNTYP=$PIECE($GET(^AUTTINTY(BARALLC,0)),U,2)
+23 IF INSTYP="I"
SET ^XTMP("BARDYSVZ","TXS SCREENED FOR INSTYP=I")=$GET(^XTMP("BARDYSVZ","TXS SCREENED FOR INSTYP=I"))+1
+24 ;DO NOT INCLUDE 'INDIAN PATIENT' BILLS PER MEETING 4/7/2009
IF INSTYP="I"
QUIT
+25 IF '$DATA(^BAROMB($JOB,BARVLOC,BARVDA,"TRANS REC",TRANDATE))
Begin DoDot:2
+26 SET TRANREC="T"_U_RECHDR_U_TRANDATE_U_INSURER_U_TRANTYP_U_$PIECE(TRANDATE,".")_U_CREDDEB_U_ADJCAT_U_ADJTYP_U_CURAMT_U_INSTYP
+27 SET ^BAROMB($JOB,BARVLOC,BILLIEN,"TRANS REC",TRANDATE)=TRANREC
End DoDot:2
End DoDot:1
+28 QUIT
+29 ;
GEREV(BARVDA,VPCCREV) ;EP - GET LAST DATE 'REVIEWED'
+1 ;PER DAVID BATTESE GET REVIEW DATE FROM V CHART AUDIT IF TURNED ON
+2 NEW TMP,QUEAUDIT,EARLIEST
+3 ;FIELD 'EHR/CHART AUDIT START DATE' FROM 'PCC MASTER CONTROL'
SET QUEAUDIT=$$GET1^DIQ(9001000,DUZ(2)_",",.12,"I")
+4 ;IF ADMIT DATE IS BEFORE AUDIT WAS TURNED ON GET REVIEW DATE FROM 'DATE LAST MODIFIED'
IF BARVADMT<QUEAUDIT
QUIT VPCCREV
+5 ;OTHERWISE SEE IF YOU CAN GET IT IN THE 'V CHART AUDIT' FILE
Begin DoDot:1
+6 ;^AUPNVCA = V CHART AUDIT
SET (PCCREV,TMP)=""
+7 FOR
SET TMP=$ORDER(^AUPNVCA("AD",BARVDA,TMP))
IF 'TMP
QUIT
Begin DoDot:2
+8 ;CHART AUDIT STATUS, R=REVIEWED/COMPLETE I=INCOMPLETE
IF $$GET1^DIQ(9000010.45,TMP_",",.04)="R"
Begin DoDot:3
+9 ;DATE OF AUDIT
SET PCCREV=$$GET1^DIQ(9000010.45,BARVDA_",",.01)
End DoDot:3
End DoDot:2
End DoDot:1
+10 ;IF A "R" DATE OF AUDIT WAS FOUND THEN USE IT
IF PCCREV
SET PCCREV=PCCREV_"A"
+11 ;OTHERWISE STAY WITH THE 'DATE LAST MODIFIED'
IF '$TEST
SET PCCREV=VPCCREV_"V"
+12 QUIT PCCREV
+13 ;
SETVISIT ;EP - SET THE VISIT AND BILL RECORDS SORTED BY VISIT
+1 NEW VISITREC,BILLREC,RECHDR,TRANREC
+2 SET (BILLREC,VISITREC)=""
+3 SET RECHDR=BARVLOC_U_BARVDA_U_BARMY
+4 ;
+5 IF '$DATA(^BAROMB($JOB,BARVLOC,BARVDA,"A VISITREC"))
Begin DoDot:1
+6 ;'SERVICE CATEGORY'
SET VISITREC=RECHDR_U_BARSCAT
+7 ;'VISIT TYPE'
SET VISITREC=VISITREC_U_BARVTYP
+8 ;'DATE VISIT CREATED'
SET VISITREC=VISITREC_U_$GET(VSITCRET)
+9 ;'VISIT/ADMIT DATE&TIME'
SET VISITREC=VISITREC_U_$GET(BARVADMT)
+10 ;"VISIT REVIEWED DATE" SEE $$GETREV
SET VISITREC=VISITREC_U_$GET(PCCREV)
+11 ;'LOC. OF ENCOUNTER' - NAME
SET VISITREC=VISITREC_U_BARLOCN
+12 SET ^BAROMB($JOB,BARVLOC,BARVDA,"A VISITREC")="V"_U_VISITREC
End DoDot:1
+13 ;
+14 ;
+15 IF '$DATA(^BAROMB($JOB,BARVLOC,BARVDA,"BILLREC",BILLIEN))
Begin DoDot:1
+16 SET BILLREC=RECHDR_U_BILLIEN
+17 SET BILLREC=BILLREC_U_BILLNUM_U_BILLAPP_U_BILLAMT_U_BILLEXP_U_ACTINS
+18 SET ^BAROMB($JOB,BARVLOC,BARVDA,"BILLREC",BILLIEN)="B"_U_BILLREC
End DoDot:1
+19 QUIT
+20 ;
SETBILL ;EP - SET THE VISIT AND BILL RECORDS SORTED BY BILL
+1 NEW VISITREC,BILLREC,RECHDR,TRANREC
+2 SET (BILLREC,VISITREC)=""
+3 SET RECHDR=BARVLOC_U_BILLIEN_U_BARMY
+4 ;
+5 IF '$DATA(^BAROMB($JOB,BARVLOC,BILLIEN,"BILLREC"))
Begin DoDot:1
+6 SET BILLREC=RECHDR_U_BILLIEN
+7 SET BILLREC=BILLREC_U_BILLNUM_U_BILLAPP_U_BILLAMT_U_BILLEXP_U_ACTINS
+8 SET ^BAROMB($JOB,BARVLOC,BILLIEN,"BILLREC",BARVDA)="B"_U_BILLREC
End DoDot:1
+9 ;
+10 ;
+11 IF '$DATA(^BAROMB($JOB,BARVLOC,BILLIEN,"Q VISITREC",BARVDA))
Begin DoDot:1
+12 ;VISIT IEN
SET VISITREC=RECHDR_U_BARVDA
+13 ;'SERVICE CATEGORY'
SET VISITREC=VISITREC_U_BARSCAT
+14 ;'VISIT TYPE'
SET VISITREC=VISITREC_U_BARVTYP
+15 ;'DATE VISIT CREATED'
SET VISITREC=VISITREC_U_$GET(VSITCRET)
+16 ;'VISIT/ADMIT DATE&TIME'
SET VISITREC=VISITREC_U_$GET(BARVADMT)
+17 ;"VISIT REVIEWED DATE" SEE $$GETREV
SET VISITREC=VISITREC_U_$GET(PCCREV)
+18 ;'LOC. OF ENCOUNTER' - NAME
SET VISITREC=VISITREC_U_BARLOCN
+19 SET ^BAROMB($JOB,BARVLOC,BILLIEN,"Q VISITREC",BARVDA)="V"_U_VISITREC
End DoDot:1
+20 QUIT
+21 ;
+22 ;
ASKFNAME(BARFILE,BEGDATE,ENDDATE) ;EP - ASK FOR FILENAME (COPIED FROM BARUFUT1)
+1 SET BARFILE=$$GETFILNM(BEGDATE,ENDDATE)
+2 WRITE !!,"File will be created using the following name: ",BARFILE
+3 QUIT 1
+4 ;
GETFILNM(BEGDATE,ENDDATE) ;EP - CREATE FILE NAME (COPIED FROM BARUFUT1)
+1 NEW FNROOT,FNEXT,FN,YR,DATE,TIME,DATETIME,BARPK,BARPT,BARP2,BARP3,DATERANG
+2 SET FNROOT="IHS_AR_OMB_"_DUZ_"_"_$$GETSUFAC()
+3 SET FNXREF=DUZ_"_"_$$GETSUFAC()
+4 SET BARV=$$VERSION^XPDUTL("BAR")
+5 SET BARP2=$$FILLSTR^BARUFUT1($PIECE(BARV,".",2),2,"R","0")
+6 SET BARPK=$ORDER(^DIC(9.4,"C","BAR",0))
+7 SET BARPK="IHS ACCOUNTS RECEIVABLE"
+8 SET BARPT=$$LAST^XPDUTL(BARPK,BARV)
+9 SET BARP3=$$FILLSTR^BARUFUT1(+BARPT,2,"R","0")
+10 SET FNXT=$PIECE(BARV,".",1)_"."_BARP2_"."_BARP3
+11 SET FNEXT="_"_FNXT_".DAT"
+12 SET FN=FNROOT
GETFILAG ;CHECK FOR FILE NAME ALREADY USED (COPIED FROM BARUFUT1)
+1 DO NOW^%DTC
+2 SET YR=1700+$EXTRACT(%,1,3)
+3 SET DATE=YR_$EXTRACT(%,4,7)
+4 SET Y=%
XECUTE ^DD("DD")
+5 SET TIME=$TRANSLATE($PIECE(Y,"@",2),":")
+6 IF $LENGTH(TIME)=4
SET TIME=TIME_"00"
+7 SET DATETIME=DATE_"_"_TIME
+8 SET DATERANG="-"_BEGDATE_"-"_ENDDATE_"-"
+9 SET FN=FNROOT_"_"_DATETIME_DATERANG
+10 SET FN=FN_FNEXT
+11 QUIT FN
+12 ;
GETSUFAC() ;EP;GIVEN DUZ(2) (COPIED FROM BARUFUT1)
+1 ; get parent from parent/satellite file
+2 NEW BARSAT,BARPAR,DA,ASUFAC
+3 SET BARSAT=DUZ(2)
+4 ; Parent
SET BARPAR=0
+5 ; check site active at DOS to ensure bill added to correct site
+6 SET DA=0
+7 FOR
SET DA=$ORDER(^BAR(90052.06,DA))
IF DA'>0
QUIT
Begin DoDot:1
+8 ; Pos Parent UNDEF Site Parameter
IF '$DATA(^BAR(90052.06,DA,DA))
QUIT
+9 ; Satellite UNDEF Parent/Satellit
IF '$DATA(^BAR(90052.05,DA,BARSAT))
QUIT
+10 ; Par/Sat not usable
IF +$PIECE($GET(^BAR(90052.05,DA,BARSAT,0)),U,5)
QUIT
+11 ; Q if sat NOT active at DT
+12 IF DT<$PIECE($GET(^BAR(90052.05,DA,BARSAT,0)),U,6)
QUIT
+13 ; Q if sat became NOT active before DT
+14 IF $PIECE($GET(^BAR(90052.05,DA,BARSAT,0)),U,7)
IF (DT>$PIECE($GET(^BAR(90052.05,DA,BARSAT,0)),U,7))
QUIT
+15 SET BARPAR=$SELECT(BARSAT:$PIECE($GET(^BAR(90052.05,DA,BARSAT,0)),U,3),1:"")
End DoDot:1
IF BARPAR
QUIT
+16 SET ASUFAC=$$CURASUFC(BARPAR,DT)
+17 QUIT ASUFAC
+18 ;
CURASUFC(LOCIEN,BARDOS) ;EP - GET CURRENT ASUFAC BASED ON 'DOS BEGIN' (#102) IN A/R BILL FILE (COPIED FROM BARUFUT1)
+1 IF LOCIEN=""
QUIT "UNPOPL"
+2 IF BARDOS=""
QUIT "UNPOPD"
+3 NEW ASUFAC,BARDT,BARDTFLG
+4 SET ASUFAC=""
+5 SET BARDT=0
+6 SET BARDTFLG=0
+7 ;First take it from 'asufac index" field
SET ASUFAC=$$GET1^DIQ(9999999.06,DUZ(2)_",",.12)
+8 ;if not, check class multiple
+9 IF 'ASUFAC
Begin DoDot:1
+10 FOR
SET BARDT=$ORDER(^AUTTLOC(LOCIEN,11,BARDT))
IF BARDT=""!(BARDTFLG=1)
QUIT
Begin DoDot:2
+11 IF BARDOS>$PIECE($GET(^AUTTLOC(LOCIEN,11,BARDT,0)),U)
Begin DoDot:3
+12 SET ASUFAC=$PIECE($GET(^AUTTLOC(LOCIEN,11,BARDT,0)),U,6)
+13 SET BARDTFLG=1
End DoDot:3
End DoDot:2
End DoDot:1
+14 ;S:ASUFAC="" ASUFAC=$$GET1^DIQ(9999999.06,DUZ(2)_",",.12)
+15 QUIT ASUFAC
+16 ;
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
