IBTUBO3 ;ALB/RB - UNBILLED AMOUNTS - GENERATE UNBILLED REPORTS ;03 Aug 2004 9:12 AM
;;2.0;INTEGRATED BILLING;**123,159,192,155,277,516,547,608,665**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
REPORT ; - Prepare report if requested, send summary bulletin.
N IBDIV,IBN,IBPAG,IBQ,IBRUN,DFN,DTE,FL,PT,X0,X1
S IBRUN=$$HTE^XLFDT($H,1)
D BULL^IBTUBUL G:'IBDET REPRTQ
;
REPRT1 ;
S (IBPAG,IBQ)=0
;I '$D(^TMP($J)) S X0="" D HDR,NIM D:'IBQ PAUSE G REPRTQ
I '$O(^TMP($J,"IBTUB",0)) S X0="",IBDIV=999999 D HDR,NIM D:'IBQ PAUSE G REPRTQ
I $G(IBSBD) D SUMPG
S IBDIV=0
I $D(^TMP($J,"IBTUB-DIV")) D G REPRT1Q
. F S IBDIV=$O(^TMP($J,"IBTUB-DIV",IBDIV)) Q:'IBDIV D REPRT2
F S IBDIV=$O(^TMP($J,"IBTUB",IBDIV)) Q:'IBDIV D REPRT2
;
REPRT1Q ;
;
;WCJ;IB*2.0*665
;D:'IBQ PAUSE
D:'IBQ EOR
;
REPRTQ Q
;
SUMPG ;IB*2.0*547/TAZ - Summary page to show which Division has blank pages for selected reports.
N IBND
S IBDIV=0
F S IBDIV=$O(^DG(40.8,IBDIV)) Q:'IBDIV D
. I $D(^TMP($J,"IBTUB-DIV")),'$D(^TMP($J,"IBTUB-DIV",IBDIV)) Q ;Not a selected division
. F X0=1,2,3 I IBSEL[X0 D Q:IBQ
.. S X1=$S(X0=2:"OPT",X0=3:"RX",1:"INPT")
.. I '$D(^TMP($J,"IBTUB",IBDIV,X1)) S IBND(X0,IBDIV)=""
I $D(IBND) D
. S IBPAG=1 W !
. W !,"Unbilled Amounts Report"
. W ?60,"Run Date: ",IBRUN,?124,"Page ",$J(IBPAG,3)
. W !,"No data for the following Divisions for the selected reports:"
. F X0=1,2,3 I IBSEL[X0 D Q:IBQ
.. W !,$S(X0=2:"Outpatient:",X0=3:"Prescriptions:",1:"Inpatient:")
.. S IBDIV=0 W !
.. F S IBDIV=$O(IBND(X0,IBDIV)) Q:'IBDIV D Q:IBQ
... I $Y>(IOSL-6) D HDR Q:IBQ W !,$S(X0=2:"Outpatient:",X0=3:"Prescriptions:",1:"Inpatient:")," Cont'd",!
... W $$GET1^DIQ(40.8,IBDIV_",",.01),!
.. W !
Q
;
REPRT2 ;Print Detail lines
F X0=1,2,3 I IBSEL[X0 D Q:IBQ
. S X1=$S(X0=2:"OPT",X0=3:"RX",1:"INPT")
. I IBSBD,'$D(^TMP($J,"IBTUB",IBDIV,X1)) Q ;IB*2.0*547/TAZ Suppress blank pages for Sort by Division
. D HDR Q:IBQ I '$D(^TMP($J,"IBTUB",IBDIV,X1)) D NIM Q
. S PT="" F S PT=$O(^TMP($J,"IBTUB",IBDIV,X1,PT)) Q:PT="" D Q:IBQ
.. S DFN=+$P(PT,"@@",2) Q:'DFN
.. S (DTE,FL)="" F S DTE=$O(^TMP($J,"IBTUB",IBDIV,X1,PT,DTE)) Q:DTE="" D Q:IBQ
... S IBX="" F S IBX=$O(^TMP($J,"IBTUB",IBDIV,X1,PT,DTE,IBX)) Q:IBX="" D Q:IBQ
.... S IBN=^TMP($J,"IBTUB",IBDIV,X1,PT,DTE,IBX) D LINE Q:IBQ I X1["OPT" D CPTS Q:IBQ
Q
;
HDR ; - Output header.
N I,X,XTP,IBDIVHDR
I $E(IOST,1,2)="C-",IBPAG D PAUSE G HDRQ:IBQ
I '$G(IBPAG) W !
I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
S IBDIVHDR=""
I IBDIV=999999 S IBDIVHDR=$S('IBSBD&$D(^TMP($J,"IBTUB-DIV")):"SELECTED",'$G(IBSBD):"ALL",1:"UNKNOWN")
E S IBDIVHDR=$$GET1^DIQ(40.8,IBDIV_",",.01)_" ("_$$GET1^DIQ(40.8,IBDIV_",",1)_")"
S IBPAG=$G(IBPAG)+1
W !,"Unbilled Amounts Report"
W ?60,"Run Date: ",IBRUN,?124,"Page ",$J(IBPAG,3)
S XTP=$S(X0=1:"INPATIENT",X0=2:"OUTPATIENT",X0=3:"PRESCRIPTIONS",1:"")
I X0'=3 S XTP=XTP_" EPISODES"
;S X="ALL "_XTP_" FROM " ;JRA;IB*2.0*608 ';'
S X=$S(($G(IBMCCF)="M"&(X0=2)):"MCCF CLAIMS - ",($G(IBMCCF)="N"&(X0=2)):"NON-MCCF CLAIMS - ",($G(IBMCCF)="B"&(X0=2)):"MCCF & NON-MCCF CLAIMS - ",1:"") ;JRA;IB*2.0*608
S X=X_"ALL "_XTP_" FROM " ;JRA;IB*2.0*608
S X=X_$$DTE(IBBDT)_" TO "_$$DTE(IBEDT\1)_" FOR DIVISION: "_IBDIVHDR
I $G(IBCOMP) S X=X_" / DATA RECOMPILED/STORED FOR "_$$DAT2^IBOUTL(IBTIMON)
S X=X_" / '*' AFTER THE PATIENT NAME = USUALLY BILLED MEANS TEST COPAYMENT"
I X0=1 S X=X_" / 'H' AFTER THE ADMISSION DATE = PATIENT CURRENTLY HOSPITALIZED"
I X0=3 S X=X_" / '$' AFTER THE ORIGINAL FILL DATE = ORIGINAL FILL DATE HAS BEEN BILLED"
S X=X_" / 'CF' COLUMN = NUMBER OF CLAIMS ON FILE FOR THE EPISODE"
I X0'=3 D
. S X=X_" / 'I/P' COLUMN = 'I' - INSTITUTIONAL CLAIM MISSING," ;JRA IB*2.0*608 Fix misspelling 'INSTUTIONAL' => 'INSTITUTIONAL'
. S X=X_" 'P' - PROFESSIONAL CLAIM MISSING"
. Q
F I=1:1 W !,$E(X,1,132) S X=$E(X,133,999) Q:X=""
;
I 'X0 W !,$TR($J(" ",IOM)," ","-"),! G HDRQ
W !!?29,"Last Prim. Claims" W:X0=3 ?52,"Fill",?123,"Original"
W !,"Name",?29,"4SSN Elig. Track.ID#"
I X0=1 W ?52,"Admission CF Insurance Carrier(s)",?98,"I/P",?102,"MRA"
I X0=2 W ?52,"Care Dt. CF Insurance Carrier(s)",?98,"I/P",?102,"MRA",?106,"CPT I. Rate P. Rate"
I X0=3 W ?52,"Date CF Ins. Carrier(s) MRA Drug Name Physician",?123,"Fill Dt."
W !,$TR($J(" ",IOM)," ","-"),!
I $D(ZTQUEUED),$$S^%ZTLOAD D
. W !!,"...Task stoped at user request"
. S (IBQ,ZTSTOP)=1
. Q
;
HDRQ Q
;
CPTS ; - Outpatient Only (CPTs and Rates)
N CPT,IBN1
I $O(^TMP($J,"IBTUB",IBDIV,X1,PT,DTE,IBX,""))="" W ?98,"I",?103,$S('$G(IBINMRA):"",$G(^TMP($J,X1_"_MRA",PT,DTE,IBX)):"M",1:"") W ! Q
S CPT="" F S CPT=$O(^TMP($J,"IBTUB",IBDIV,X1,PT,DTE,IBX,CPT)) Q:CPT="" D Q:IBQ
. S IBN1=^TMP($J,"IBTUB",IBDIV,X1,PT,DTE,IBX,CPT)
. I $Y>(IOSL-5) D HDR Q:IBQ S FL=0 D LINE
. W ?98,$P(IBN1,U,3),?103,$S('$G(IBINMRA):"",$G(^TMP($J,"IBTUB",IBDIV,X1_"_MRA",PT,DTE,IBX)):"M",1:""),?106,CPT,?113,$J(+IBN1,8,2)
. W ?124,$J($P(IBN1,U,2),8,2),!
Q
;
LINE ; - Print detail line.
I $Y>(IOSL-6) D HDR G:IBQ LINQ S FL=0
I 'FL D
. W $E($P(PT,"@@"),1,26) I $$BIL^DGMTUB(DFN,+DTE) W " *"
. W ?29,$$SSN(DFN),?34,$E($$ELIG(DFN),1,5) S FL=1
;
W ?39,$J(IBX,11)
; - Inpatient and Outpatient Only
I X1'["RX" D
. W ?52,$$DTE(+DTE) W:X1["INPT" $S($P(IBN,U,5):"H",1:"")
. W ?62,$J($P(IBN,U),2),?65,$$INS(DFN,+DTE,34)
. I X1["INPT" D
.. I $P(IBN,U,2)'="" W ?98,$E($P(IBN,U,2),1,3),!
.. I '$G(^TMP($J,"IBTUB",IBDIV,X1_"_MRA",PT,DTE,IBX))!'$G(IBINMRA) W:$P(IBN,U,2)="" ! Q
.. W ?98,$E($P(^TMP($J,"IBTUB",IBDIV,X1_"_MRA",PT,DTE,IBX),U,2),1,3),?103,"M",!
;
; - Pharmacy Only
I X1["RX" D G LINQ
. W ?52,$$DTE(+DTE),?61,$J($P(IBN,U),2),?64,$$INS(DFN,+DTE,19),?85,$S('$G(IBINMRA):"",$G(^TMP($J,X1_"_MRA",PT,DTE,IBX)):"M",1:"")
. W ?88,$E($P(IBN,U,6),1,15),?105,$E($P(IBN,U,2),1,14)
. W ?123,$$DTE($P(IBN,U,3)) W:$P(IBN,"^",5) "$" W !
;
LINQ Q
;
SSN(DFN) ; - Return last 4 of patient's SSN.
N SSN,VADM
D DEM^VADPT S SSN=$P(VADM(2),"^"),SSN=$E(SSN,6,9) D KVA^VADPT
Q SSN
;
ELIG(DFN) ; - Return patient's primary eligibility (1st 10 characters).
N ELIG,VAEL
D ELIG^VADPT S ELIG=$E($P(VAEL(1),"^",2),1,10) D KVAR^VADPT
Q ELIG
;
DTE(D) ; - Format date (MM/DD/YY or MM/YY).
Q $S('$G(D):"",1:$E(D,4,5)_"/"_$S($E(D,6,7)'="00":$E(D,6,7)_"/",1:"")_$E(D,2,3))
;
INS(P,D,C) ; - Return patient's insurance carrier(s).
; Input: P=patient IEN, D=event date, C=Size of the Ins.Carrier column
; Output: List of Providers
;
I '$G(P)!('$G(D)) Q ""
;
N INSC,INSL,INSN,LST,TMP,X
;
S INSL="" D ALL^IBCNS1(P,"LST",1,D)
S X=0 F S X=$O(LST(X)) Q:'X D
. S INSC=+$G(LST(X,0)) Q:$D(TMP(INSC))!'INSC
. S INSN=$P($G(^DIC(36,INSC,0)),U)
. I $G(LST(0))>1 S INSN=$E(INSN,1,C\2)
. S INSL=INSL_","_INSN
. S TMP(INSC)=""
;
S $E(INSL)=""
I $L(INSL,",")>1,$L(INSL)>C D
. S INSL=$E(INSL,1,C-3),$P(INSL,",",$L(INSL,","))="..."
S INSL=$E(INSL,1,C)
;
Q INSL
;
NIM ; - Print 'no info' message.
W !?3,"No information available for the period specified."
Q
;
PAUSE ; - Page break.
I $E(IOST,1,2)'="C-" Q
I IOSL>24 Q ;User is creating a continuous document to a log file.
N IBI,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
F IBI=$Y:1:(IOSL-3) W !
S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
Q
;
;WCJ;IB*2.0*665
EOR ; - End of Report
I $E(IOST,1,2)'="C-"!(IOSL>24) D WEOR Q ;User is creating a continuous document to a log file.
F IBI=$Y:1:(IOSL-5) W !
D WEOR
N IBI,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
Q
;
WEOR ; - End of Report Visual Indicator
W !,?(IOM-$L("*** END OF REPORT ***")\2),"*** END OF REPORT ***",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTUBO3 7807 printed Dec 13, 2024@02:29:08 Page 2
IBTUBO3 ;ALB/RB - UNBILLED AMOUNTS - GENERATE UNBILLED REPORTS ;03 Aug 2004 9:12 AM
+1 ;;2.0;INTEGRATED BILLING;**123,159,192,155,277,516,547,608,665**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
REPORT ; - Prepare report if requested, send summary bulletin.
+1 NEW IBDIV,IBN,IBPAG,IBQ,IBRUN,DFN,DTE,FL,PT,X0,X1
+2 SET IBRUN=$$HTE^XLFDT($HOROLOG,1)
+3 DO BULL^IBTUBUL
if 'IBDET
GOTO REPRTQ
+4 ;
REPRT1 ;
+1 SET (IBPAG,IBQ)=0
+2 ;I '$D(^TMP($J)) S X0="" D HDR,NIM D:'IBQ PAUSE G REPRTQ
+3 IF '$ORDER(^TMP($JOB,"IBTUB",0))
SET X0=""
SET IBDIV=999999
DO HDR
DO NIM
if 'IBQ
DO PAUSE
GOTO REPRTQ
+4 IF $GET(IBSBD)
DO SUMPG
+5 SET IBDIV=0
+6 IF $DATA(^TMP($JOB,"IBTUB-DIV"))
Begin DoDot:1
+7 FOR
SET IBDIV=$ORDER(^TMP($JOB,"IBTUB-DIV",IBDIV))
if 'IBDIV
QUIT
DO REPRT2
End DoDot:1
GOTO REPRT1Q
+8 FOR
SET IBDIV=$ORDER(^TMP($JOB,"IBTUB",IBDIV))
if 'IBDIV
QUIT
DO REPRT2
+9 ;
REPRT1Q ;
+1 ;
+2 ;WCJ;IB*2.0*665
+3 ;D:'IBQ PAUSE
+4 if 'IBQ
DO EOR
+5 ;
REPRTQ QUIT
+1 ;
SUMPG ;IB*2.0*547/TAZ - Summary page to show which Division has blank pages for selected reports.
+1 NEW IBND
+2 SET IBDIV=0
+3 FOR
SET IBDIV=$ORDER(^DG(40.8,IBDIV))
if 'IBDIV
QUIT
Begin DoDot:1
+4 ;Not a selected division
IF $DATA(^TMP($JOB,"IBTUB-DIV"))
IF '$DATA(^TMP($JOB,"IBTUB-DIV",IBDIV))
QUIT
+5 FOR X0=1,2,3
IF IBSEL[X0
Begin DoDot:2
+6 SET X1=$SELECT(X0=2:"OPT",X0=3:"RX",1:"INPT")
+7 IF '$DATA(^TMP($JOB,"IBTUB",IBDIV,X1))
SET IBND(X0,IBDIV)=""
End DoDot:2
if IBQ
QUIT
End DoDot:1
+8 IF $DATA(IBND)
Begin DoDot:1
+9 SET IBPAG=1
WRITE !
+10 WRITE !,"Unbilled Amounts Report"
+11 WRITE ?60,"Run Date: ",IBRUN,?124,"Page ",$JUSTIFY(IBPAG,3)
+12 WRITE !,"No data for the following Divisions for the selected reports:"
+13 FOR X0=1,2,3
IF IBSEL[X0
Begin DoDot:2
+14 WRITE !,$SELECT(X0=2:"Outpatient:",X0=3:"Prescriptions:",1:"Inpatient:")
+15 SET IBDIV=0
WRITE !
+16 FOR
SET IBDIV=$ORDER(IBND(X0,IBDIV))
if 'IBDIV
QUIT
Begin DoDot:3
+17 IF $Y>(IOSL-6)
DO HDR
if IBQ
QUIT
WRITE !,$SELECT(X0=2:"Outpatient:",X0=3:"Prescriptions:",1:"Inpatient:")," Cont'd",!
+18 WRITE $$GET1^DIQ(40.8,IBDIV_",",.01),!
End DoDot:3
if IBQ
QUIT
+19 WRITE !
End DoDot:2
if IBQ
QUIT
End DoDot:1
+20 QUIT
+21 ;
REPRT2 ;Print Detail lines
+1 FOR X0=1,2,3
IF IBSEL[X0
Begin DoDot:1
+2 SET X1=$SELECT(X0=2:"OPT",X0=3:"RX",1:"INPT")
+3 ;IB*2.0*547/TAZ Suppress blank pages for Sort by Division
IF IBSBD
IF '$DATA(^TMP($JOB,"IBTUB",IBDIV,X1))
QUIT
+4 DO HDR
if IBQ
QUIT
IF '$DATA(^TMP($JOB,"IBTUB",IBDIV,X1))
DO NIM
QUIT
+5 SET PT=""
FOR
SET PT=$ORDER(^TMP($JOB,"IBTUB",IBDIV,X1,PT))
if PT=""
QUIT
Begin DoDot:2
+6 SET DFN=+$PIECE(PT,"@@",2)
if 'DFN
QUIT
+7 SET (DTE,FL)=""
FOR
SET DTE=$ORDER(^TMP($JOB,"IBTUB",IBDIV,X1,PT,DTE))
if DTE=""
QUIT
Begin DoDot:3
+8 SET IBX=""
FOR
SET IBX=$ORDER(^TMP($JOB,"IBTUB",IBDIV,X1,PT,DTE,IBX))
if IBX=""
QUIT
Begin DoDot:4
+9 SET IBN=^TMP($JOB,"IBTUB",IBDIV,X1,PT,DTE,IBX)
DO LINE
if IBQ
QUIT
IF X1["OPT"
DO CPTS
if IBQ
QUIT
End DoDot:4
if IBQ
QUIT
End DoDot:3
if IBQ
QUIT
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+10 QUIT
+11 ;
HDR ; - Output header.
+1 NEW I,X,XTP,IBDIVHDR
+2 IF $EXTRACT(IOST,1,2)="C-"
IF IBPAG
DO PAUSE
if IBQ
GOTO HDRQ
+3 IF '$GET(IBPAG)
WRITE !
+4 IF $EXTRACT(IOST,1,2)="C-"!$GET(IBPAG)
WRITE @IOF,*13
+5 SET IBDIVHDR=""
+6 IF IBDIV=999999
SET IBDIVHDR=$SELECT('IBSBD&$DATA(^TMP($JOB,"IBTUB-DIV")):"SELECTED",'$GET(IBSBD):"ALL",1:"UNKNOWN")
+7 IF '$TEST
SET IBDIVHDR=$$GET1^DIQ(40.8,IBDIV_",",.01)_" ("_$$GET1^DIQ(40.8,IBDIV_",",1)_")"
+8 SET IBPAG=$GET(IBPAG)+1
+9 WRITE !,"Unbilled Amounts Report"
+10 WRITE ?60,"Run Date: ",IBRUN,?124,"Page ",$JUSTIFY(IBPAG,3)
+11 SET XTP=$SELECT(X0=1:"INPATIENT",X0=2:"OUTPATIENT",X0=3:"PRESCRIPTIONS",1:"")
+12 IF X0'=3
SET XTP=XTP_" EPISODES"
+13 ;S X="ALL "_XTP_" FROM " ;JRA;IB*2.0*608 ';'
+14 ;JRA;IB*2.0*608
SET X=$SELECT(($GET(IBMCCF)="M"&(X0=2)):"MCCF CLAIMS - ",($GET(IBMCCF)="N"&(X0=2)):"NON-MCCF CLAIMS - ",($GET(IBMCCF)="B"&(X0=2)):"MCCF & NON-MCCF CLAIMS - ",1:"")
+15 ;JRA;IB*2.0*608
SET X=X_"ALL "_XTP_" FROM "
+16 SET X=X_$$DTE(IBBDT)_" TO "_$$DTE(IBEDT\1)_" FOR DIVISION: "_IBDIVHDR
+17 IF $GET(IBCOMP)
SET X=X_" / DATA RECOMPILED/STORED FOR "_$$DAT2^IBOUTL(IBTIMON)
+18 SET X=X_" / '*' AFTER THE PATIENT NAME = USUALLY BILLED MEANS TEST COPAYMENT"
+19 IF X0=1
SET X=X_" / 'H' AFTER THE ADMISSION DATE = PATIENT CURRENTLY HOSPITALIZED"
+20 IF X0=3
SET X=X_" / '$' AFTER THE ORIGINAL FILL DATE = ORIGINAL FILL DATE HAS BEEN BILLED"
+21 SET X=X_" / 'CF' COLUMN = NUMBER OF CLAIMS ON FILE FOR THE EPISODE"
+22 IF X0'=3
Begin DoDot:1
+23 ;JRA IB*2.0*608 Fix misspelling 'INSTUTIONAL' => 'INSTITUTIONAL'
SET X=X_" / 'I/P' COLUMN = 'I' - INSTITUTIONAL CLAIM MISSING,"
+24 SET X=X_" 'P' - PROFESSIONAL CLAIM MISSING"
+25 QUIT
End DoDot:1
+26 FOR I=1:1
WRITE !,$EXTRACT(X,1,132)
SET X=$EXTRACT(X,133,999)
if X=""
QUIT
+27 ;
+28 IF 'X0
WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-"),!
GOTO HDRQ
+29 WRITE !!?29,"Last Prim. Claims"
if X0=3
WRITE ?52,"Fill",?123,"Original"
+30 WRITE !,"Name",?29,"4SSN Elig. Track.ID#"
+31 IF X0=1
WRITE ?52,"Admission CF Insurance Carrier(s)",?98,"I/P",?102,"MRA"
+32 IF X0=2
WRITE ?52,"Care Dt. CF Insurance Carrier(s)",?98,"I/P",?102,"MRA",?106,"CPT I. Rate P. Rate"
+33 IF X0=3
WRITE ?52,"Date CF Ins. Carrier(s) MRA Drug Name Physician",?123,"Fill Dt."
+34 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-"),!
+35 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
Begin DoDot:1
+36 WRITE !!,"...Task stoped at user request"
+37 SET (IBQ,ZTSTOP)=1
+38 QUIT
End DoDot:1
+39 ;
HDRQ QUIT
+1 ;
CPTS ; - Outpatient Only (CPTs and Rates)
+1 NEW CPT,IBN1
+2 IF $ORDER(^TMP($JOB,"IBTUB",IBDIV,X1,PT,DTE,IBX,""))=""
WRITE ?98,"I",?103,$SELECT('$GET(IBINMRA):"",$GET(^TMP($JOB,X1_"_MRA",PT,DTE,IBX)):"M",1:"")
WRITE !
QUIT
+3 SET CPT=""
FOR
SET CPT=$ORDER(^TMP($JOB,"IBTUB",IBDIV,X1,PT,DTE,IBX,CPT))
if CPT=""
QUIT
Begin DoDot:1
+4 SET IBN1=^TMP($JOB,"IBTUB",IBDIV,X1,PT,DTE,IBX,CPT)
+5 IF $Y>(IOSL-5)
DO HDR
if IBQ
QUIT
SET FL=0
DO LINE
+6 WRITE ?98,$PIECE(IBN1,U,3),?103,$SELECT('$GET(IBINMRA):"",$GET(^TMP($JOB,"IBTUB",IBDIV,X1_"_MRA",PT,DTE,IBX)):"M",1:""),?106,CPT,?113,$JUSTIFY(+IBN1,8,2)
+7 WRITE ?124,$JUSTIFY($PIECE(IBN1,U,2),8,2),!
End DoDot:1
if IBQ
QUIT
+8 QUIT
+9 ;
LINE ; - Print detail line.
+1 IF $Y>(IOSL-6)
DO HDR
if IBQ
GOTO LINQ
SET FL=0
+2 IF 'FL
Begin DoDot:1
+3 WRITE $EXTRACT($PIECE(PT,"@@"),1,26)
IF $$BIL^DGMTUB(DFN,+DTE)
WRITE " *"
+4 WRITE ?29,$$SSN(DFN),?34,$EXTRACT($$ELIG(DFN),1,5)
SET FL=1
End DoDot:1
+5 ;
+6 WRITE ?39,$JUSTIFY(IBX,11)
+7 ; - Inpatient and Outpatient Only
+8 IF X1'["RX"
Begin DoDot:1
+9 WRITE ?52,$$DTE(+DTE)
if X1["INPT"
WRITE $SELECT($PIECE(IBN,U,5):"H",1:"")
+10 WRITE ?62,$JUSTIFY($PIECE(IBN,U),2),?65,$$INS(DFN,+DTE,34)
+11 IF X1["INPT"
Begin DoDot:2
+12 IF $PIECE(IBN,U,2)'=""
WRITE ?98,$EXTRACT($PIECE(IBN,U,2),1,3),!
+13 IF '$GET(^TMP($JOB,"IBTUB",IBDIV,X1_"_MRA",PT,DTE,IBX))!'$GET(IBINMRA)
if $PIECE(IBN,U,2)=""
WRITE !
QUIT
+14 WRITE ?98,$EXTRACT($PIECE(^TMP($JOB,"IBTUB",IBDIV,X1_"_MRA",PT,DTE,IBX),U,2),1,3),?103,"M",!
End DoDot:2
End DoDot:1
+15 ;
+16 ; - Pharmacy Only
+17 IF X1["RX"
Begin DoDot:1
+18 WRITE ?52,$$DTE(+DTE),?61,$JUSTIFY($PIECE(IBN,U),2),?64,$$INS(DFN,+DTE,19),?85,$SELECT('$GET(IBINMRA):"",$GET(^TMP($JOB,X1_"_MRA",PT,DTE,IBX)):"M",1:"")
+19 WRITE ?88,$EXTRACT($PIECE(IBN,U,6),1,15),?105,$EXTRACT($PIECE(IBN,U,2),1,14)
+20 WRITE ?123,$$DTE($PIECE(IBN,U,3))
if $PIECE(IBN,"^",5)
WRITE "$"
WRITE !
End DoDot:1
GOTO LINQ
+21 ;
LINQ QUIT
+1 ;
SSN(DFN) ; - Return last 4 of patient's SSN.
+1 NEW SSN,VADM
+2 DO DEM^VADPT
SET SSN=$PIECE(VADM(2),"^")
SET SSN=$EXTRACT(SSN,6,9)
DO KVA^VADPT
+3 QUIT SSN
+4 ;
ELIG(DFN) ; - Return patient's primary eligibility (1st 10 characters).
+1 NEW ELIG,VAEL
+2 DO ELIG^VADPT
SET ELIG=$EXTRACT($PIECE(VAEL(1),"^",2),1,10)
DO KVAR^VADPT
+3 QUIT ELIG
+4 ;
DTE(D) ; - Format date (MM/DD/YY or MM/YY).
+1 QUIT $SELECT('$GET(D):"",1:$EXTRACT(D,4,5)_"/"_$SELECT($EXTRACT(D,6,7)'="00":$EXTRACT(D,6,7)_"/",1:"")_$EXTRACT(D,2,3))
+2 ;
INS(P,D,C) ; - Return patient's insurance carrier(s).
+1 ; Input: P=patient IEN, D=event date, C=Size of the Ins.Carrier column
+2 ; Output: List of Providers
+3 ;
+4 IF '$GET(P)!('$GET(D))
QUIT ""
+5 ;
+6 NEW INSC,INSL,INSN,LST,TMP,X
+7 ;
+8 SET INSL=""
DO ALL^IBCNS1(P,"LST",1,D)
+9 SET X=0
FOR
SET X=$ORDER(LST(X))
if 'X
QUIT
Begin DoDot:1
+10 SET INSC=+$GET(LST(X,0))
if $DATA(TMP(INSC))!'INSC
QUIT
+11 SET INSN=$PIECE($GET(^DIC(36,INSC,0)),U)
+12 IF $GET(LST(0))>1
SET INSN=$EXTRACT(INSN,1,C\2)
+13 SET INSL=INSL_","_INSN
+14 SET TMP(INSC)=""
End DoDot:1
+15 ;
+16 SET $EXTRACT(INSL)=""
+17 IF $LENGTH(INSL,",")>1
IF $LENGTH(INSL)>C
Begin DoDot:1
+18 SET INSL=$EXTRACT(INSL,1,C-3)
SET $PIECE(INSL,",",$LENGTH(INSL,","))="..."
End DoDot:1
+19 SET INSL=$EXTRACT(INSL,1,C)
+20 ;
+21 QUIT INSL
+22 ;
NIM ; - Print 'no info' message.
+1 WRITE !?3,"No information available for the period specified."
+2 QUIT
+3 ;
PAUSE ; - Page break.
+1 IF $EXTRACT(IOST,1,2)'="C-"
QUIT
+2 ;User is creating a continuous document to a log file.
IF IOSL>24
QUIT
+3 NEW IBI,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+4 FOR IBI=$Y:1:(IOSL-3)
WRITE !
+5 SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)!($DATA(DUOUT))
SET IBQ=1
+6 QUIT
+7 ;
+8 ;WCJ;IB*2.0*665
EOR ; - End of Report
+1 ;User is creating a continuous document to a log file.
IF $EXTRACT(IOST,1,2)'="C-"!(IOSL>24)
DO WEOR
QUIT
+2 FOR IBI=$Y:1:(IOSL-5)
WRITE !
+3 DO WEOR
+4 NEW IBI,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+5 SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)!($DATA(DUOUT))
SET IBQ=1
+6 QUIT
+7 ;
WEOR ; - End of Report Visual Indicator
+1 WRITE !,?(IOM-$LENGTH("*** END OF REPORT ***")\2),"*** END OF REPORT ***",!
+2 QUIT
