BARDYSVZ.m

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