- 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 Jan 18, 2025@03:30:19 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