- IBTUBO ;ALB/AAS - UNBILLED AMOUNTS - GENERATE UNBILLED REPORTS ;29-SEP-94
- ;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159,192,235,248,155,516,547,608,665**;21-MAR-94;Build 28
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ; Reference to 409.1 in ICR #4671
- ; Reference to 8 in ICR #427
- ;
- % ; - Entry point for manual option.
- N IBBDT,IBCOMP,IBDET,IBEDT,IBOPT,IBPRT,IBTIMON,IBQUIT,IBSEL,IBSBD
- S (IBQUIT,IBSBD)=0 D:'$D(DT) DT^DICRW
- W !!,"Re-Generate Unbilled Amounts Report",!
- ;
- ; - Ask to re-compile Unbilled Amounts data.
- S DIR(0)="Y",DIR("B")="NO"
- S DIR("A")="Do you want to store Unbilled Amounts figures"
- S DIR("?",1)="Enter 'YES' if you wish to store the Unbilled Amounts summary"
- S DIR("?",2)="figures in your system for a specific month/year in the past."
- S DIR("?",3)="Once stored, these figures will be available for inquiry through"
- S DIR("?",4)="the View Unbilled Amounts option [IBT VIEW UNBILLED AMOUNTS]."
- S DIR("?",5)="These summary figures are normally calculated and stored"
- S DIR("?",6)="automatically by the system at the beginning of each month for"
- S DIR("?",7)="the previous month."
- S DIR("?",8)=" "
- S DIR("?",9)="If you enter 'NO', the Unbilled Amounts summary figures will"
- S DIR("?",10)="NOT be stored in your system, and the report may be run for"
- S DIR("?")="any date range."
- D ^DIR K DIR G:$D(DIRUT) END S IBCOMP=Y
- ;
- ; IB*2.0*516 - Added ability to sort by Division
- ;
- K ^TMP($J,"IBTUB"),^TMP($J,"IBTUB-DIV")
- I IBCOMP G RDATE
- ;
- ;IB*2.0*547/TAZ - Add prompt to search by division. If NO bypass all division selection.
- S DIR(0)="Y",DIR("B")="NO" W !
- S DIR("A")="Search by Division?"
- S DIR("?",1)=" This opt allows you to search for all unbilled amounts"
- S DIR("?",2)=" or to search for unbilled amounts in only one or more"
- S DIR("?",3)=" divisions."
- S DIR("?",4)=""
- S DIR("?",5)="Choose from:"
- S DIR("?",6)=" N NO"
- S DIR("?")=" Y YES"
- D ^DIR K DIR G:$D(DIRUT) END
- S IBSBD=Y I 'IBSBD G DIVX
- ;
- DIV ; division
- W !!
- S DIR(0)="SA^A:All Divisions;S:Selected Divisions"
- S DIR("A")="Include All Divisions or Selected Divisions? "
- S DIR("B")="All"
- D ^DIR K DIR
- I $D(DIROUT)!$D(DIRUT) Q ;Timeout or User "^"
- I Y="A" G DIVX
- ;
- W !
- F D I IBQUIT S IBQUIT=IBQUIT-1 Q
- . S DIC=40.8,DIC(0)="AEMQ",DIC("A")=" Select Division: "
- . I $O(^TMP($J,"IBTUB-DIV","")) S DIC("A")=" Select Another Division: "
- . D ^DIC K DIC ; lookup
- . I X="^^" S IBQUIT=2 Q ; user entered ^^
- . I +Y'>0 S IBQUIT=1 Q ; user is done
- . S ^TMP($J,"IBTUB-DIV",+Y)=$P(Y,U,2)
- . Q
- ;
- I IBQUIT G END ;User "^" out of the selection
- ;
- I '$O(^TMP($J,"IBTUB-DIV","")) D G DIV
- . W *7,!!?3,"No divisions have been selected. Please try again."
- . Q
- ;
- DIVX ; Exit Division selection.
- ;
- ;JRA;IB*2.0*608 Ask to Search by MCCF, Non-MCCF or Both - Start
- N ARTIEN,ARTYP,ELIG,ELIGIEN,LN,X ;JRA;IB*2*665 Moved up from below and added LN
- ;
- ;JRA;IB*2*665 Set up array of non-MCCF Rate Types
- S ARTIEN="" F S ARTIEN=$O(^IBE(350.9,1,28,"B",ARTIEN)) Q:'ARTIEN D
- . S IBMCCF("RTYP",ARTIEN)=$$GET1^DIQ(399.3,ARTIEN_",",.01,"I")
- ;
- W !
- S DIR(0)="SA^M:MCCF;N:Non-MCCF (Outpatient Only);B:Both"
- S DIR("A")="Search by (M)CCF, (N)on-MCCF (Outpatient Only), or (B)oth? "
- S DIR("B")="M"
- S DIR("?",1)="Non-MCCF Eligibilities of Encounter are: 'CHAMPVA', 'INELIGIBLE',"
- S DIR("?",2)=" 'EMPLOYEE', 'TRICARE' and 'SHARING AGREEMENT'."
- S DIR("?",3)="Non-MCCF Appointment Types are: 'EMPLOYEE' and 'SHARING AGREEMENT'."
- ;S DIR("?",4)="Non-MCCF Rate Types are 'CHAMPVA REIMB. INS.', 'CHAMPVA'," ;JRA;IB*2*665 ';'
- ;S DIR("?",5)=" 'TRICARE REIMB. INS.', 'TRICARE', 'INELIGIBLE' and 'INTERAGENCY'." ;JRA;IB*2*665 ';'
- S DIR("?",4)="Non-MCCF Rate Types are:" ;JRA;IB*2*665
- S ARTIEN="",LN=5 F S ARTIEN=$O(IBMCCF("RTYP",ARTIEN)) Q:ARTIEN="" D ;JRA;IB*2*665
- . I $L($G(DIR("?",LN)))+($L(" '"_IBMCCF("RTYP",ARTIEN)_"',"))>80 S DIR("?",LN)=DIR("?",LN)_",",LN=LN+1 ;JRA;IB*2*665
- . S DIR("?",LN)=$S($G(DIR("?",LN))="":" '"_IBMCCF("RTYP",ARTIEN)_"'",1:DIR("?",LN)_", '"_IBMCCF("RTYP",ARTIEN)_"'") ;JRA;IB*2*665
- S DIR("?",LN)=DIR("?",LN)_"." ;JRA;IB*2*665
- S DIR("?")="All other Eligibilities/Types are MCCF."
- D ^DIR K DIR G:($D(DIROUT)!($D(DIRUT))) END
- S IBMCCF=Y
- ;Set up arrays of Non-MCCF Rate Types, Non-MCCF Appointment Types and Non-MCCF Eligibility of Encounter entries.
- ;N ARTIEN,ARTYP,ELIG,ELIGIEN,X ;JRA;IB*2*665 ';'
- ;F ARTYP="INTERAGENCY","CHAMPVA REIMB. INS.","CHAMPVA","TRICARE REIMB. INS.","TRICARE","INELIGIBLE" D ;Non-MCCF Rate Types ;JRA;IB*2*665 ';'
- ;. S ARTIEN=$O(^DGCR(399.3,"B",ARTYP,"")) I +ARTIEN S IBMCCF("RTYP",ARTIEN)="" ;JRA;IB*2*665 ';'
- F ARTYP="EMPLOYEE","SHARING AGREEMENT" D ;Non-MCCF Appointment Types
- . ;DBIA4671 for following FIND^DIC
- . K ^TMP("DILIST",$J) D FIND^DIC(409.1,,"@;.01","X",ARTYP) I $D(^TMP("DILIST",$J,2))>1 D
- . . S X=0 F S X=$O(^TMP("DILIST",$J,2,X)) Q:'X S ARTIEN=^TMP("DILIST",$J,2,X) S:+ARTIEN IBMCCF("ATYP",ARTIEN)=""
- F ELIG="CHAMPVA","INELIGIBLE","EMPLOYEE","TRICARE","SHARING AGREEMENT" D ;Non-MCCF "Eligibility of Encounter" Entries
- . ;DBIA427 for following FIND^DIC
- . K ^TMP("DILIST",$J) D FIND^DIC(8,,"@;.01","X",ELIG) I $D(^TMP("DILIST",$J,2))>1 D
- . . S X=0 F S X=$O(^TMP("DILIST",$J,2,X)) Q:'X S ELIGIEN=^TMP("DILIST",$J,2,X) S:+ELIGIEN IBMCCF("ELIG",ELIGIEN)=""
- ;JRA;IB*2.0*608 - End
- ;
- ; - Select date(s) to build report.
- W ! D DT1^IBTUBOU G:IBBDT="^" END
- ;
- ; - Select report(s).
- S IBPRT="Choose report type(s) to print:"
- ;S IBOPT(1)="INPATIENT UNBILLED" ;JRA;IB*2.0*608 ';'
- ;S IBOPT(2)="OUTPATIENT UNBILLED" ;JRA;IB*2.0*608 ';'
- ;S IBOPT(3)="PRESCRIPTION UNBILLED" ;JRA;IB*2.0*608 ';'
- ;S IBOPT(4)="ALL OF THE ABOVE" ;JRA;IB*2.0*608 ';'
- I $G(IBMCCF)="N" S IBOPT(1)="OUTPATIENT UNBILLED" ;JRA;IB*2.0*608
- E D ;JRA;IB*2.0*608
- . S IBOPT(1)="INPATIENT UNBILLED"
- . S IBOPT(2)="OUTPATIENT UNBILLED"
- . S IBOPT(3)="PRESCRIPTION UNBILLED"
- . S IBOPT(4)="ALL OF THE ABOVE"
- ;S IBSEL=$$MLTP^IBJD(IBPRT,.IBOPT,1) I 'IBSEL G END ;JRA;IB*2.0*608 ';'
- S IBSEL=$$MLTP^IBJD(IBPRT,.IBOPT,$S($G(IBMCCF)="N":"",1:1)) I 'IBSEL G END ;JRA;IB*2.0*608
- ;JRA;IB*2.0*608 For Non-MCCF set IBSEL="2," since the value of IBSEL drives the computations and '2' is for Outpatient.
- ; Since "OUTPATIENT UNBILLED" is the only choice for Non-MCCF, IBSEL will be set to '1,' so need to reset to '2,'.
- S:$G(IBMCCF)="N" IBSEL="2," ;JRA;IB*2.0*608
- S $E(IBSEL,$L(IBSEL))=""
- ;
- RDATE ; - Select re-compile date, if necessary.
- I IBCOMP D G END:IBTIMON="^",DET
- . W ! D DT2("Unbilled Amounts") Q:IBTIMON="^"
- . W !!,"NOTE: Just a reminder that by entering the above month/year this"
- . W !," report will re-calculate and update the Unbilled Amounts"
- . W !," data on file in your system.",*7
- . ;
- . ; - Initialize variables
- . I IBTIMON<3030900 N X S X=$$M2^IBJDE(IBTIMON,11,11) D
- .. S IBBDT=+X,IBEDT=$P(X,U,2)+.9,IBSEL="1,2,3"
- . I IBTIMON'<3030900 S IBBDT=$$M3^IBJDE($$LDATE^IBJDE(IBTIMON)+1),IBEDT=$$LDATE^IBJDE(IBTIMON)+.9,IBSEL="1,2,3"
- . D MSG W !
- ;
- S IBTIMON=IBEDT\100*100
- ;
- DET ; - Ask to print detail report.
- S DIR(0)="Y",DIR("B")="NO" W !
- S DIR("A")="Print detail report with the Unbilled Amounts summary"
- S DIR("?",1)="Answer YES if you want a detailed listing of the patients"
- S DIR("?",2)="and events that are unbilled. Answer NO if you just want"
- S DIR("?")="the summary, or '^' to quit this option."
- D ^DIR K DIR G:$D(DIRUT) END S IBDET=Y G:'IBDET QUE
- ;
- ; Ask to include REQUEST MRA Status
- S DIR(0)="YA",DIR("A")="Do you want to include MRA claims?: ",DIR("B")="NO" W ! D ^DIR K DIR G:$D(DIRUT) END
- S IBINMRA=+Y
- ;
- ;IB*2.0*547/TAZ - Add prompt to sort by Patient or Divsion if Division Search was selected.
- I $G(IBSBD) D G:$D(DIRUT) END
- . S DIR("A")="Sort by: ",DIR("B")="Patient Name" W !
- . S DIR(0)="SA^N:PATIENT NAME;D:DIVISION^S:X="""" X=""N"""
- . S DIR("?",1)=" This determines whether the unbilled amounts are displayed"
- . S DIR("?",2)=" in alphabetical order of patient name or in alphabetical "
- . S DIR("?")=" order of patient name within a division."
- . D ^DIR K DIR
- . S IBSBD=Y="D" ;IBSBD=0 - Sort by Patient Name, IBSBD=1, Sort by Patient Name within Division.
- ;
- ; - Select device to print.
- W !!,"This report takes a while to run, so you should queue it to run"
- W !,"after normal business hours."
- W !!,"You will need a 132 column printer for this report!",!
- S %ZIS="QM" D ^%ZIS G END:POP,QUE:$D(IO("Q"))
- ;
- U IO G STR
- ;
- QUE ; - Queue report/summary, if necessary.
- W ! I 'IBDET S ZTIO=""
- S ZTRTN="IBTUBOA",ZTSAVE("IB*")=""
- S ZTDESC="IB - Unbilled Amounts Report"
- D ^%ZTLOAD K IO("Q"),ZTSK
- D HOME^%ZIS G END
- ;
- AUTO ; - Entry point for scheduled option.
- Q ;;**NO LONGER USED**
- ;
- DQ ; - Entry point for DM extract.
- ; - If AUTO PRINT UNBILLED LIST=yes and default report printer then
- ; automatically requeue to device.
- I $P(^IBE(350.9,1,6),U,24) D G END:'$G(IBXTRACT)
- . N X S X=$O(^IBE(353,"B","IB REPORTS",0))
- . S ZTIO=$P($G(^IBE(353,+X,0)),U,2) Q:ZTIO=""
- . S IBDET=1,IBXTRACT=0,ZTDTH=$H,ZTRTN="IBTUBOA",ZTSAVE("IB*")=""
- . S ZTDESC="IB - Unbilled Amounts Report" D ^%ZTLOAD
- . S IBDET=0,IBXTRACT=1
- . K ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
- ;
- STR D ^IBTUBOA ; Start report.
- ;
- END K DIRUT,IBMCCF Q ;JRA IB*2.0*608 Added IBMCCF
- ;
- MSG ; - Compile message.
- W !!,"NOTE: After this report is run, the Unbilled Amounts totals for"
- W !?6,"the month of "_$$DAT2^IBOUTL(IBTIMON)_" will be updated."
- Q
- ;
- DT2(STR) ; - Select re-compile date (returns variable IBTIMON).
- ; Input: STR - String that describe the type of data that will be
- ; re-compiled: "Unbilled Amounts", "Average Bill Amounts", etc...
- ;
- ; This code is very the same code as is in DT2^IBTUBOU... that is
- ; a utility routine, so code was copied and altered to accommodate
- ; EOAM changes.
- N DIRUT,DT0,DT1,DT2,Y
- ; - AUG 1993 is the first month on file with Unbilled Amounts data
- S DT0=2930800,DT1=$$DAT2^IBOUTL(DT0)
- I $E(DT,6,7)'>$E($$LDATE^IBJDE(DT),6,7) S DT2=DT
- I $E(DT,6,7)>$E($$LDATE^IBJDE(DT),6,7) S DT2=DT+100 I $E(DT2,4,5)=13 S DT2=DT+8900
- S DT2=$$M1^IBJDE(DT2,1),DIR("B")=$$DAT2^IBOUTL(DT2)
- S DIR(0)="DA^"_$E(DT0,1,5)_"00:"_DT2_":AE^K:$E(Y,6,7)'=""00"" X"
- S DIR("A")="Re-compile "_$G(STR)_" through MONTH/YEAR: "
- S DIR("?",1)="Enter a past month/year (ex. Oct 2000).",DIR("?",2)=""
- S DIR("?",3)="NOTE: The earliest month/year that can be entered is "_DT1_", and"
- S DIR("?")=" it is NOT possible to enter the current or a future month/year."
- D ^DIR K DIR I $D(DIRUT) S IBTIMON="^" G DT2Q
- I $E(Y,6,7)'="00"!($E(Y,4,7)="0000") W " ??" G DT2
- S IBTIMON=Y
- ;
- DT2Q Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTUBO 10819 printed Feb 18, 2025@23:55:34 Page 2
- IBTUBO ;ALB/AAS - UNBILLED AMOUNTS - GENERATE UNBILLED REPORTS ;29-SEP-94
- +1 ;;2.0;INTEGRATED BILLING;**19,31,32,91,123,159,192,235,248,155,516,547,608,665**;21-MAR-94;Build 28
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; Reference to 409.1 in ICR #4671
- +5 ; Reference to 8 in ICR #427
- +6 ;
- % ; - Entry point for manual option.
- +1 NEW IBBDT,IBCOMP,IBDET,IBEDT,IBOPT,IBPRT,IBTIMON,IBQUIT,IBSEL,IBSBD
- +2 SET (IBQUIT,IBSBD)=0
- if '$DATA(DT)
- DO DT^DICRW
- +3 WRITE !!,"Re-Generate Unbilled Amounts Report",!
- +4 ;
- +5 ; - Ask to re-compile Unbilled Amounts data.
- +6 SET DIR(0)="Y"
- SET DIR("B")="NO"
- +7 SET DIR("A")="Do you want to store Unbilled Amounts figures"
- +8 SET DIR("?",1)="Enter 'YES' if you wish to store the Unbilled Amounts summary"
- +9 SET DIR("?",2)="figures in your system for a specific month/year in the past."
- +10 SET DIR("?",3)="Once stored, these figures will be available for inquiry through"
- +11 SET DIR("?",4)="the View Unbilled Amounts option [IBT VIEW UNBILLED AMOUNTS]."
- +12 SET DIR("?",5)="These summary figures are normally calculated and stored"
- +13 SET DIR("?",6)="automatically by the system at the beginning of each month for"
- +14 SET DIR("?",7)="the previous month."
- +15 SET DIR("?",8)=" "
- +16 SET DIR("?",9)="If you enter 'NO', the Unbilled Amounts summary figures will"
- +17 SET DIR("?",10)="NOT be stored in your system, and the report may be run for"
- +18 SET DIR("?")="any date range."
- +19 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO END
- SET IBCOMP=Y
- +20 ;
- +21 ; IB*2.0*516 - Added ability to sort by Division
- +22 ;
- +23 KILL ^TMP($JOB,"IBTUB"),^TMP($JOB,"IBTUB-DIV")
- +24 IF IBCOMP
- GOTO RDATE
- +25 ;
- +26 ;IB*2.0*547/TAZ - Add prompt to search by division. If NO bypass all division selection.
- +27 SET DIR(0)="Y"
- SET DIR("B")="NO"
- WRITE !
- +28 SET DIR("A")="Search by Division?"
- +29 SET DIR("?",1)=" This opt allows you to search for all unbilled amounts"
- +30 SET DIR("?",2)=" or to search for unbilled amounts in only one or more"
- +31 SET DIR("?",3)=" divisions."
- +32 SET DIR("?",4)=""
- +33 SET DIR("?",5)="Choose from:"
- +34 SET DIR("?",6)=" N NO"
- +35 SET DIR("?")=" Y YES"
- +36 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO END
- +37 SET IBSBD=Y
- IF 'IBSBD
- GOTO DIVX
- +38 ;
- DIV ; division
- +1 WRITE !!
- +2 SET DIR(0)="SA^A:All Divisions;S:Selected Divisions"
- +3 SET DIR("A")="Include All Divisions or Selected Divisions? "
- +4 SET DIR("B")="All"
- +5 DO ^DIR
- KILL DIR
- +6 ;Timeout or User "^"
- IF $DATA(DIROUT)!$DATA(DIRUT)
- QUIT
- +7 IF Y="A"
- GOTO DIVX
- +8 ;
- +9 WRITE !
- +10 FOR
- Begin DoDot:1
- +11 SET DIC=40.8
- SET DIC(0)="AEMQ"
- SET DIC("A")=" Select Division: "
- +12 IF $ORDER(^TMP($JOB,"IBTUB-DIV",""))
- SET DIC("A")=" Select Another Division: "
- +13 ; lookup
- DO ^DIC
- KILL DIC
- +14 ; user entered ^^
- IF X="^^"
- SET IBQUIT=2
- QUIT
- +15 ; user is done
- IF +Y'>0
- SET IBQUIT=1
- QUIT
- +16 SET ^TMP($JOB,"IBTUB-DIV",+Y)=$PIECE(Y,U,2)
- +17 QUIT
- End DoDot:1
- IF IBQUIT
- SET IBQUIT=IBQUIT-1
- QUIT
- +18 ;
- +19 ;User "^" out of the selection
- IF IBQUIT
- GOTO END
- +20 ;
- +21 IF '$ORDER(^TMP($JOB,"IBTUB-DIV",""))
- Begin DoDot:1
- +22 WRITE *7,!!?3,"No divisions have been selected. Please try again."
- +23 QUIT
- End DoDot:1
- GOTO DIV
- +24 ;
- DIVX ; Exit Division selection.
- +1 ;
- +2 ;JRA;IB*2.0*608 Ask to Search by MCCF, Non-MCCF or Both - Start
- +3 ;JRA;IB*2*665 Moved up from below and added LN
- NEW ARTIEN,ARTYP,ELIG,ELIGIEN,LN,X
- +4 ;
- +5 ;JRA;IB*2*665 Set up array of non-MCCF Rate Types
- +6 SET ARTIEN=""
- FOR
- SET ARTIEN=$ORDER(^IBE(350.9,1,28,"B",ARTIEN))
- if 'ARTIEN
- QUIT
- Begin DoDot:1
- +7 SET IBMCCF("RTYP",ARTIEN)=$$GET1^DIQ(399.3,ARTIEN_",",.01,"I")
- End DoDot:1
- +8 ;
- +9 WRITE !
- +10 SET DIR(0)="SA^M:MCCF;N:Non-MCCF (Outpatient Only);B:Both"
- +11 SET DIR("A")="Search by (M)CCF, (N)on-MCCF (Outpatient Only), or (B)oth? "
- +12 SET DIR("B")="M"
- +13 SET DIR("?",1)="Non-MCCF Eligibilities of Encounter are: 'CHAMPVA', 'INELIGIBLE',"
- +14 SET DIR("?",2)=" 'EMPLOYEE', 'TRICARE' and 'SHARING AGREEMENT'."
- +15 SET DIR("?",3)="Non-MCCF Appointment Types are: 'EMPLOYEE' and 'SHARING AGREEMENT'."
- +16 ;S DIR("?",4)="Non-MCCF Rate Types are 'CHAMPVA REIMB. INS.', 'CHAMPVA'," ;JRA;IB*2*665 ';'
- +17 ;S DIR("?",5)=" 'TRICARE REIMB. INS.', 'TRICARE', 'INELIGIBLE' and 'INTERAGENCY'." ;JRA;IB*2*665 ';'
- +18 ;JRA;IB*2*665
- SET DIR("?",4)="Non-MCCF Rate Types are:"
- +19 ;JRA;IB*2*665
- SET ARTIEN=""
- SET LN=5
- FOR
- SET ARTIEN=$ORDER(IBMCCF("RTYP",ARTIEN))
- if ARTIEN=""
- QUIT
- Begin DoDot:1
- +20 ;JRA;IB*2*665
- IF $LENGTH($GET(DIR("?",LN)))+($LENGTH(" '"_IBMCCF("RTYP",ARTIEN)_"',"))>80
- SET DIR("?",LN)=DIR("?",LN)_","
- SET LN=LN+1
- +21 ;JRA;IB*2*665
- SET DIR("?",LN)=$SELECT($GET(DIR("?",LN))="":" '"_IBMCCF("RTYP",ARTIEN)_"'",1:DIR("?",LN)_", '"_IBMCCF("RTYP",ARTIEN)_"'")
- End DoDot:1
- +22 ;JRA;IB*2*665
- SET DIR("?",LN)=DIR("?",LN)_"."
- +23 SET DIR("?")="All other Eligibilities/Types are MCCF."
- +24 DO ^DIR
- KILL DIR
- if ($DATA(DIROUT)!($DATA(DIRUT)))
- GOTO END
- +25 SET IBMCCF=Y
- +26 ;Set up arrays of Non-MCCF Rate Types, Non-MCCF Appointment Types and Non-MCCF Eligibility of Encounter entries.
- +27 ;N ARTIEN,ARTYP,ELIG,ELIGIEN,X ;JRA;IB*2*665 ';'
- +28 ;F ARTYP="INTERAGENCY","CHAMPVA REIMB. INS.","CHAMPVA","TRICARE REIMB. INS.","TRICARE","INELIGIBLE" D ;Non-MCCF Rate Types ;JRA;IB*2*665 ';'
- +29 ;. S ARTIEN=$O(^DGCR(399.3,"B",ARTYP,"")) I +ARTIEN S IBMCCF("RTYP",ARTIEN)="" ;JRA;IB*2*665 ';'
- +30 ;Non-MCCF Appointment Types
- FOR ARTYP="EMPLOYEE","SHARING AGREEMENT"
- Begin DoDot:1
- +31 ;DBIA4671 for following FIND^DIC
- +32 KILL ^TMP("DILIST",$JOB)
- DO FIND^DIC(409.1,,"@;.01","X",ARTYP)
- IF $DATA(^TMP("DILIST",$JOB,2))>1
- Begin DoDot:2
- +33 SET X=0
- FOR
- SET X=$ORDER(^TMP("DILIST",$JOB,2,X))
- if 'X
- QUIT
- SET ARTIEN=^TMP("DILIST",$JOB,2,X)
- if +ARTIEN
- SET IBMCCF("ATYP",ARTIEN)=""
- End DoDot:2
- End DoDot:1
- +34 ;Non-MCCF "Eligibility of Encounter" Entries
- FOR ELIG="CHAMPVA","INELIGIBLE","EMPLOYEE","TRICARE","SHARING AGREEMENT"
- Begin DoDot:1
- +35 ;DBIA427 for following FIND^DIC
- +36 KILL ^TMP("DILIST",$JOB)
- DO FIND^DIC(8,,"@;.01","X",ELIG)
- IF $DATA(^TMP("DILIST",$JOB,2))>1
- Begin DoDot:2
- +37 SET X=0
- FOR
- SET X=$ORDER(^TMP("DILIST",$JOB,2,X))
- if 'X
- QUIT
- SET ELIGIEN=^TMP("DILIST",$JOB,2,X)
- if +ELIGIEN
- SET IBMCCF("ELIG",ELIGIEN)=""
- End DoDot:2
- End DoDot:1
- +38 ;JRA;IB*2.0*608 - End
- +39 ;
- +40 ; - Select date(s) to build report.
- +41 WRITE !
- DO DT1^IBTUBOU
- if IBBDT="^"
- GOTO END
- +42 ;
- +43 ; - Select report(s).
- +44 SET IBPRT="Choose report type(s) to print:"
- +45 ;S IBOPT(1)="INPATIENT UNBILLED" ;JRA;IB*2.0*608 ';'
- +46 ;S IBOPT(2)="OUTPATIENT UNBILLED" ;JRA;IB*2.0*608 ';'
- +47 ;S IBOPT(3)="PRESCRIPTION UNBILLED" ;JRA;IB*2.0*608 ';'
- +48 ;S IBOPT(4)="ALL OF THE ABOVE" ;JRA;IB*2.0*608 ';'
- +49 ;JRA;IB*2.0*608
- IF $GET(IBMCCF)="N"
- SET IBOPT(1)="OUTPATIENT UNBILLED"
- +50 ;JRA;IB*2.0*608
- IF '$TEST
- Begin DoDot:1
- +51 SET IBOPT(1)="INPATIENT UNBILLED"
- +52 SET IBOPT(2)="OUTPATIENT UNBILLED"
- +53 SET IBOPT(3)="PRESCRIPTION UNBILLED"
- +54 SET IBOPT(4)="ALL OF THE ABOVE"
- End DoDot:1
- +55 ;S IBSEL=$$MLTP^IBJD(IBPRT,.IBOPT,1) I 'IBSEL G END ;JRA;IB*2.0*608 ';'
- +56 ;JRA;IB*2.0*608
- SET IBSEL=$$MLTP^IBJD(IBPRT,.IBOPT,$SELECT($GET(IBMCCF)="N":"",1:1))
- IF 'IBSEL
- GOTO END
- +57 ;JRA;IB*2.0*608 For Non-MCCF set IBSEL="2," since the value of IBSEL drives the computations and '2' is for Outpatient.
- +58 ; Since "OUTPATIENT UNBILLED" is the only choice for Non-MCCF, IBSEL will be set to '1,' so need to reset to '2,'.
- +59 ;JRA;IB*2.0*608
- if $GET(IBMCCF)="N"
- SET IBSEL="2,"
- +60 SET $EXTRACT(IBSEL,$LENGTH(IBSEL))=""
- +61 ;
- RDATE ; - Select re-compile date, if necessary.
- +1 IF IBCOMP
- Begin DoDot:1
- +2 WRITE !
- DO DT2("Unbilled Amounts")
- if IBTIMON="^"
- QUIT
- +3 WRITE !!,"NOTE: Just a reminder that by entering the above month/year this"
- +4 WRITE !," report will re-calculate and update the Unbilled Amounts"
- +5 WRITE !," data on file in your system.",*7
- +6 ;
- +7 ; - Initialize variables
- +8 IF IBTIMON<3030900
- NEW X
- SET X=$$M2^IBJDE(IBTIMON,11,11)
- Begin DoDot:2
- +9 SET IBBDT=+X
- SET IBEDT=$PIECE(X,U,2)+.9
- SET IBSEL="1,2,3"
- End DoDot:2
- +10 IF IBTIMON'<3030900
- SET IBBDT=$$M3^IBJDE($$LDATE^IBJDE(IBTIMON)+1)
- SET IBEDT=$$LDATE^IBJDE(IBTIMON)+.9
- SET IBSEL="1,2,3"
- +11 DO MSG
- WRITE !
- End DoDot:1
- if IBTIMON="^"
- GOTO END
- GOTO DET
- +12 ;
- +13 SET IBTIMON=IBEDT\100*100
- +14 ;
- DET ; - Ask to print detail report.
- +1 SET DIR(0)="Y"
- SET DIR("B")="NO"
- WRITE !
- +2 SET DIR("A")="Print detail report with the Unbilled Amounts summary"
- +3 SET DIR("?",1)="Answer YES if you want a detailed listing of the patients"
- +4 SET DIR("?",2)="and events that are unbilled. Answer NO if you just want"
- +5 SET DIR("?")="the summary, or '^' to quit this option."
- +6 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO END
- SET IBDET=Y
- if 'IBDET
- GOTO QUE
- +7 ;
- +8 ; Ask to include REQUEST MRA Status
- +9 SET DIR(0)="YA"
- SET DIR("A")="Do you want to include MRA claims?: "
- SET DIR("B")="NO"
- WRITE !
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO END
- +10 SET IBINMRA=+Y
- +11 ;
- +12 ;IB*2.0*547/TAZ - Add prompt to sort by Patient or Divsion if Division Search was selected.
- +13 IF $GET(IBSBD)
- Begin DoDot:1
- +14 SET DIR("A")="Sort by: "
- SET DIR("B")="Patient Name"
- WRITE !
- +15 SET DIR(0)="SA^N:PATIENT NAME;D:DIVISION^S:X="""" X=""N"""
- +16 SET DIR("?",1)=" This determines whether the unbilled amounts are displayed"
- +17 SET DIR("?",2)=" in alphabetical order of patient name or in alphabetical "
- +18 SET DIR("?")=" order of patient name within a division."
- +19 DO ^DIR
- KILL DIR
- +20 ;IBSBD=0 - Sort by Patient Name, IBSBD=1, Sort by Patient Name within Division.
- SET IBSBD=Y="D"
- End DoDot:1
- if $DATA(DIRUT)
- GOTO END
- +21 ;
- +22 ; - Select device to print.
- +23 WRITE !!,"This report takes a while to run, so you should queue it to run"
- +24 WRITE !,"after normal business hours."
- +25 WRITE !!,"You will need a 132 column printer for this report!",!
- +26 SET %ZIS="QM"
- DO ^%ZIS
- if POP
- GOTO END
- if $DATA(IO("Q"))
- GOTO QUE
- +27 ;
- +28 USE IO
- GOTO STR
- +29 ;
- QUE ; - Queue report/summary, if necessary.
- +1 WRITE !
- IF 'IBDET
- SET ZTIO=""
- +2 SET ZTRTN="IBTUBOA"
- SET ZTSAVE("IB*")=""
- +3 SET ZTDESC="IB - Unbilled Amounts Report"
- +4 DO ^%ZTLOAD
- KILL IO("Q"),ZTSK
- +5 DO HOME^%ZIS
- GOTO END
- +6 ;
- AUTO ; - Entry point for scheduled option.
- +1 ;;**NO LONGER USED**
- QUIT
- +2 ;
- DQ ; - Entry point for DM extract.
- +1 ; - If AUTO PRINT UNBILLED LIST=yes and default report printer then
- +2 ; automatically requeue to device.
- +3 IF $PIECE(^IBE(350.9,1,6),U,24)
- Begin DoDot:1
- +4 NEW X
- SET X=$ORDER(^IBE(353,"B","IB REPORTS",0))
- +5 SET ZTIO=$PIECE($GET(^IBE(353,+X,0)),U,2)
- if ZTIO=""
- QUIT
- +6 SET IBDET=1
- SET IBXTRACT=0
- SET ZTDTH=$HOROLOG
- SET ZTRTN="IBTUBOA"
- SET ZTSAVE("IB*")=""
- +7 SET ZTDESC="IB - Unbilled Amounts Report"
- DO ^%ZTLOAD
- +8 SET IBDET=0
- SET IBXTRACT=1
- +9 KILL ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
- End DoDot:1
- if '$GET(IBXTRACT)
- GOTO END
- +10 ;
- STR ; Start report.
- DO ^IBTUBOA
- +1 ;
- END ;JRA IB*2.0*608 Added IBMCCF
- KILL DIRUT,IBMCCF
- QUIT
- +1 ;
- MSG ; - Compile message.
- +1 WRITE !!,"NOTE: After this report is run, the Unbilled Amounts totals for"
- +2 WRITE !?6,"the month of "_$$DAT2^IBOUTL(IBTIMON)_" will be updated."
- +3 QUIT
- +4 ;
- DT2(STR) ; - Select re-compile date (returns variable IBTIMON).
- +1 ; Input: STR - String that describe the type of data that will be
- +2 ; re-compiled: "Unbilled Amounts", "Average Bill Amounts", etc...
- +3 ;
- +4 ; This code is very the same code as is in DT2^IBTUBOU... that is
- +5 ; a utility routine, so code was copied and altered to accommodate
- +6 ; EOAM changes.
- +7 NEW DIRUT,DT0,DT1,DT2,Y
- +8 ; - AUG 1993 is the first month on file with Unbilled Amounts data
- +9 SET DT0=2930800
- SET DT1=$$DAT2^IBOUTL(DT0)
- +10 IF $EXTRACT(DT,6,7)'>$EXTRACT($$LDATE^IBJDE(DT),6,7)
- SET DT2=DT
- +11 IF $EXTRACT(DT,6,7)>$EXTRACT($$LDATE^IBJDE(DT),6,7)
- SET DT2=DT+100
- IF $EXTRACT(DT2,4,5)=13
- SET DT2=DT+8900
- +12 SET DT2=$$M1^IBJDE(DT2,1)
- SET DIR("B")=$$DAT2^IBOUTL(DT2)
- +13 SET DIR(0)="DA^"_$EXTRACT(DT0,1,5)_"00:"_DT2_":AE^K:$E(Y,6,7)'=""00"" X"
- +14 SET DIR("A")="Re-compile "_$GET(STR)_" through MONTH/YEAR: "
- +15 SET DIR("?",1)="Enter a past month/year (ex. Oct 2000)."
- SET DIR("?",2)=""
- +16 SET DIR("?",3)="NOTE: The earliest month/year that can be entered is "_DT1_", and"
- +17 SET DIR("?")=" it is NOT possible to enter the current or a future month/year."
- +18 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- SET IBTIMON="^"
- GOTO DT2Q
- +19 IF $EXTRACT(Y,6,7)'="00"!($EXTRACT(Y,4,7)="0000")
- WRITE " ??"
- GOTO DT2
- +20 SET IBTIMON=Y
- +21 ;
- DT2Q QUIT