- IBJDI6 ;ALB/CPM - SC VETS W/ NSC EPISODES OF INPT CARE ; 18-DEC-96
- ;;2.0;INTEGRATED BILLING;**69,83,98,100**;21-MAR-94
- ;
- EN ; - Option entry point.
- ;
- W !!,"This report provides a number of the NSC inpatient episodes for SC veterans"
- W !,"which have and have not been billed.",!
- ;
- DATE D DATE^IBOUTL I IBBDT=""!(IBEDT="") G ENQ
- ;
- ; - Select a detailed or summary report.
- D DS^IBJD I IBRPT["^" G ENQ
- ;
- W !!,"This report only requires an 80 column printer."
- ;
- W !!,"Note: This report may take a while to run."
- W !?6,"You should queue this report to run after normal business hours.",!
- ;
- ; - Select a device.
- S %ZIS="QM" D ^%ZIS G:POP ENQ
- I $D(IO("Q")) D G ENQ
- .S ZTRTN="DQ^IBJDI6",ZTDESC="IB - SC VETS W/ NSC EPISODES"
- .F I="IBBDT","IBEDT","IBRPT" S ZTSAVE(I)=""
- .D ^%ZTLOAD
- .W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
- .K ZTSK,IO("Q") D HOME^%ZIS
- ;
- U IO
- ;
- DQ ; - Tasked entry point.
- ;
- I $G(IBXTRACT) D E^IBJDE(6,1) ; Change extract status.
- ;
- K IB,^TMP("IBJDI6",$J)
- S IBQ=0 F X="NSC","NSCB","NSCR","NSCU","SC","TOT" S IB(X)=0
- F X=0:1:3 S IB("NSCU",X)=0
- ;
- ; - Find data required for the report.
- S IBD=IBBDT-.01 F S IBD=$O(^DGPM("ATT3",IBD)) Q:'IBD!(IBD\1>IBEDT) D Q:IBQ
- .S IBPM=0 F S IBPM=$O(^DGPM("ATT3",IBD,IBPM)) Q:'IBPM D Q:IBQ
- ..I IBPM#100=0 S IBQ=$$STOP^IBOUTL("SC Vets w/NSC Episodes") Q:IBQ
- ..S IBPMD=$G(^DGPM(IBPM,0)) Q:'IBPMD
- ..S DFN=+$P(IBPMD,U,3) Q:'DFN
- ..I $$TESTP^IBJDI1(DFN) Q ; Test patient.
- ..S IBDIS=+IBPMD\1
- ..;
- ..; - Patient must be insured, and SC.
- ..I '$$INSURED^IBCNS1(DFN,IBDIS) Q
- ..D ELIG^VADPT Q:'VAEL(3)
- ..;
- ..; - Set 'totals' accumulator.
- ..S IB("TOT")=IB("TOT")+1
- ..;
- ..; - See if associated PTF record has NSC movements.
- ..S IBADMD=$G(^DGPM(+$P(IBPMD,U,14),0))
- ..S IBPTF=+$P(IBADMD,U,16),IBSTAT=$P($G(^DGPT(IBPTF,0)),U,6)
- ..I '$$PTF(IBPTF) S IB("SC")=IB("SC")+1 Q
- ..S IB("NSC")=IB("NSC")+1
- ..;
- ..; - See if there is a claim for the NSC episode.
- ..S IBADM=+IBADMD\1
- ..I $$BILL(IBPTF,DFN,IBADM,IBDIS) S IB("NSCB")=IB("NSCB")+1 Q
- ..;
- ..; - Has episode been flagged as non-billable?
- ..S IBCT=$O(^IBT(356,"AD",+$P(IBPMD,U,14),0))
- ..I IBCT,$P($G(^IBT(356,IBCT,0)),U,19) S IB("NSCR")=IB("NSCR")+1 Q
- ..;
- ..S IB("NSCU")=IB("NSCU")+1
- ..S IB("NSCU",IBSTAT)=IB("NSCU",IBSTAT)+1
- ..I IBRPT="D" D
- ...S X=$G(^DPT(DFN,0))
- ...S ^TMP("IBJDI6",$J,$P(X,U)_"@@"_DFN)=$P(X,U,9)
- ...S ^TMP("IBJDI6",$J,$P(X,U)_"@@"_DFN,IBADM)=$S(IBSTAT=0:"OPEN",IBSTAT=1:"CLOSED",IBSTAT=2:"RELEASED",1:"TRANSMITTED")_U_IBDIS
- ;
- I IBQ G ENQ
- ;
- I $G(IBXTRACT) D E^IBJDE(6,0) G ENQ ; Extract summary data.
- ;
- ; - Print the reports.
- S (IBPAG,IBQ)=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
- I IBRPT="D" D DET
- I 'IBQ D SUM
- ;
- I 'IBQ D PAUSE
- ;
- ENQ K ^TMP("IBJDI6",$J)
- I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
- ;
- D ^%ZISC
- ENQ1 K IB,IBQ,IBBDT,IBEDT,IBRPT,IBD,IBDN,IBPAG,IBRUN,IBX,IBX1,IBX2
- K IBADM,IBDIS,IBCT,IBH,IBPER,IBPM,IBPMD,IBPMDT,IBPTF,IBSTAT,IBADMD
- K %,%ZIS,DFN,POP,VA,VAERR,VAEL,X,Y,ZTDESC,ZTRTN,ZTSAVE
- Q
- ;
- DET ; - Print the detailed report.
- D HDET Q:IBQ
- I '$D(^TMP("IBJDI6",$J)) D G DETQ
- .I IB("NSC") W !!,"All NSC episodes for SC veterans in the selected date range have been billed." Q
- .W !!,"There were no NSC episodes found in the selected date range."
- ;
- S IBX="" F S IBX=$O(^TMP("IBJDI6",$J,IBX)) Q:IBX="" S IBX1=^(IBX) D Q:IBQ
- .S (IBH,IBADM)=0 F S IBADM=$O(^TMP("IBJDI6",$J,IBX,IBADM)) Q:'IBADM S IBX2=^(IBADM) D Q:IBQ
- ..I $Y>(IOSL-2) D PAUSE Q:IBQ D HDET Q:IBQ S IBH=0
- ..W ! I 'IBH D PAT S IBH=1
- ..W ?46,$P(IBX2,U),?59,$$DAT1^IBOUTL(IBADM),?69,$$DAT1^IBOUTL($P(IBX2,U,2))
- ;
- DETQ I 'IBQ D PAUSE
- Q
- ;
- PAT ; - Write the patient information.
- W $P(IBX,"@@"),?32,$$SSN(IBX1)
- Q
- ;
- HDET ; - Write the detail report header.
- I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
- S IBPAG=IBPAG+1
- W !,"Insured SC Vets w/ Unbilled NSC Care",?38,"Run Date: ",IBRUN,?70,"Page: ",IBPAG
- W !,"For Patients discharged in the period "_$$DAT1^IBOUTL(IBBDT)_" to "_$$DAT1^IBOUTL(IBEDT)
- W !,"Patient",?32,"SSN",?46,"PTF Status",?59,"Adm Date",?69,"Disc Date"
- W !,$$DASH(80)
- S IBQ=$$STOP^IBOUTL("SC Vets w/NSC Episodes")
- Q
- ;
- SUM ; - Print the summary report.
- I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
- S IBPAG=IBPAG+1
- W !!?13,"INSURED SC VETERANS W/ UNBILLED NSC INPATIENT EPISODES"
- W !?33,"SUMMARY REPORT"
- W !!?16,"For Patients discharged from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
- W !!?24,"Run Date: ",IBRUN,!?24,$$DASH(31),!!
- ;
- S IBPER(1)=$S('IB("TOT"):0,1:$J(IB("SC")/IB("TOT")*100,0,2))
- S IBPER(2)=$S('IB("NSC"):0,1:$J(IB("NSCB")/IB("NSC")*100,0,2))
- S IBPER(3)=$S('IB("NSC"):0,1:$J(IB("NSCR")/IB("NSC")*100,0,2))
- W ?9,"Number of Discharges of Insured SC Veterans:",?54,$J(IB("TOT"),4)
- W !?5,"Discharges Which were totally Service-Connected:",?54,$J(IB("SC"),4),?62,"(",IBPER(1),"%)"
- W !,"Discharges Which included Non-Service Connected Care:",?54,$J(IB("NSC"),4),?62,"(",$J($S('IB("TOT"):0,1:100-IBPER(1)),0,2),"%)"
- W !?10,"Number of NSC Discharges Which were Billed:",?54,$J(IB("NSCB"),4),?62,"(",IBPER(2),"%)"
- W !?4,"Number of NSC Discharges Flagged as Non-Billable:",?54,$J(IB("NSCR"),4),?62,"(",IBPER(3),"%)"
- W !?19,"Number of Unbilled NSC Discharges:",?54,$J(IB("NSCU"),4),?62,"(",$J($S('IB("NSC"):0,1:100-IBPER(2)-IBPER(3)),0,2),"%)",!?54,"----"
- F X=0:1:3 D
- .I X=0 W !,"Unbilled NSC Discharges w/ PTF Status of"
- .W ?41,$S(X=0:"Open",X=1:"Closed",X=2:"Released",1:"Transmitted"),":",?54,$J(IB("NSCU",X),4),?62,"(",$J($S('IB("NSCU",X):0,1:IB("NSCU",X)/IB("NSCU")*100),0,2),"%)",!
- Q
- ;
- DASH(X) ; - Return a dashed line.
- Q $TR($J("",X)," ","=")
- ;
- PAUSE ; - Page break.
- I $E(IOST,1,2)'="C-" Q
- N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
- F IBX=$Y:1:(IOSL-3) W !
- S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
- Q
- ;
- SSN(X) ; - Format the SSN.
- Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
- ;
- PTF(IBPTF) ; - Does the PTF record have an NSC-related movement?
- ; Input: IBPTF = Pointer to the PTF record in file #45
- ; Output: IBNSC = 1 (NSC movement) or 0 (No NSC movement)
- ;
- N IBNSC,X,Y
- S (IBNSC,X)=0
- I '$G(IBPTF) G PTFQ
- ;
- ; - Check PTF movements for a movement not related to SC care.
- F S X=$O(^DGPT(IBPTF,"M",X)) Q:'X S Y=$P($G(^(X,0)),U,18) I Y'=1 S IBNSC=1 Q
- ;
- PTFQ Q IBNSC
- ;
- BILL(IBPTF,DFN,IBADM,IBDIS) ; - Has this episode of care been billed?
- ; Input: IBPTF = Pointer to the PTF record in file #45
- ; DFN = Pointer to the patient in file #2
- ; IBADM = Episode admission date
- ; IBDIS = Episode discharge date
- ; Output: BILL = 1 (Episode has been billed)
- ; 0 (Episode has not been billed)
- ;
- N BILL,X,X1,XU,Y
- S BILL=0
- ;
- ; - See if there is a claim based on the PTF record.
- I $G(IBPTF) D G:BILL BILLQ
- .S X=0 F S X=$O(^DGCR(399,"APTF",IBPTF,X)) Q:'X S Y=$P($G(^DGCR(399,X,0)),U,13) I Y,Y<7 S BILL=1 Q
- ;
- ; - Check other inpatient bills for care provided in the adm/dis period.
- S X=0 F S X=$O(^DGCR(399,"C",+$G(DFN),X)) Q:'X D Q:BILL
- .S X1=$G(^DGCR(399,X,0)),XU=$G(^("U")) Q:X1=""
- .I $P(X1,U,5)>2 Q ; Outpatient care.
- .I $P(X1,U,13)=7 Q ; Bill is cancelled.
- .I +XU\1<IBADM!($P(XU,U,2)\1>IBEDT) Q ; Care outside of range.
- .S BILL=1
- ;
- BILLQ Q BILL
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDI6 7437 printed Mar 13, 2025@21:28:19 Page 2
- IBJDI6 ;ALB/CPM - SC VETS W/ NSC EPISODES OF INPT CARE ; 18-DEC-96
- +1 ;;2.0;INTEGRATED BILLING;**69,83,98,100**;21-MAR-94
- +2 ;
- EN ; - Option entry point.
- +1 ;
- +2 WRITE !!,"This report provides a number of the NSC inpatient episodes for SC veterans"
- +3 WRITE !,"which have and have not been billed.",!
- +4 ;
- DATE DO DATE^IBOUTL
- IF IBBDT=""!(IBEDT="")
- GOTO ENQ
- +1 ;
- +2 ; - Select a detailed or summary report.
- +3 DO DS^IBJD
- IF IBRPT["^"
- GOTO ENQ
- +4 ;
- +5 WRITE !!,"This report only requires an 80 column printer."
- +6 ;
- +7 WRITE !!,"Note: This report may take a while to run."
- +8 WRITE !?6,"You should queue this report to run after normal business hours.",!
- +9 ;
- +10 ; - Select a device.
- +11 SET %ZIS="QM"
- DO ^%ZIS
- if POP
- GOTO ENQ
- +12 IF $DATA(IO("Q"))
- Begin DoDot:1
- +13 SET ZTRTN="DQ^IBJDI6"
- SET ZTDESC="IB - SC VETS W/ NSC EPISODES"
- +14 FOR I="IBBDT","IBEDT","IBRPT"
- SET ZTSAVE(I)=""
- +15 DO ^%ZTLOAD
- +16 WRITE !!,$SELECT($DATA(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
- +17 KILL ZTSK,IO("Q")
- DO HOME^%ZIS
- End DoDot:1
- GOTO ENQ
- +18 ;
- +19 USE IO
- +20 ;
- DQ ; - Tasked entry point.
- +1 ;
- +2 ; Change extract status.
- IF $GET(IBXTRACT)
- DO E^IBJDE(6,1)
- +3 ;
- +4 KILL IB,^TMP("IBJDI6",$JOB)
- +5 SET IBQ=0
- FOR X="NSC","NSCB","NSCR","NSCU","SC","TOT"
- SET IB(X)=0
- +6 FOR X=0:1:3
- SET IB("NSCU",X)=0
- +7 ;
- +8 ; - Find data required for the report.
- +9 SET IBD=IBBDT-.01
- FOR
- SET IBD=$ORDER(^DGPM("ATT3",IBD))
- if 'IBD!(IBD\1>IBEDT)
- QUIT
- Begin DoDot:1
- +10 SET IBPM=0
- FOR
- SET IBPM=$ORDER(^DGPM("ATT3",IBD,IBPM))
- if 'IBPM
- QUIT
- Begin DoDot:2
- +11 IF IBPM#100=0
- SET IBQ=$$STOP^IBOUTL("SC Vets w/NSC Episodes")
- if IBQ
- QUIT
- +12 SET IBPMD=$GET(^DGPM(IBPM,0))
- if 'IBPMD
- QUIT
- +13 SET DFN=+$PIECE(IBPMD,U,3)
- if 'DFN
- QUIT
- +14 ; Test patient.
- IF $$TESTP^IBJDI1(DFN)
- QUIT
- +15 SET IBDIS=+IBPMD\1
- +16 ;
- +17 ; - Patient must be insured, and SC.
- +18 IF '$$INSURED^IBCNS1(DFN,IBDIS)
- QUIT
- +19 DO ELIG^VADPT
- if 'VAEL(3)
- QUIT
- +20 ;
- +21 ; - Set 'totals' accumulator.
- +22 SET IB("TOT")=IB("TOT")+1
- +23 ;
- +24 ; - See if associated PTF record has NSC movements.
- +25 SET IBADMD=$GET(^DGPM(+$PIECE(IBPMD,U,14),0))
- +26 SET IBPTF=+$PIECE(IBADMD,U,16)
- SET IBSTAT=$PIECE($GET(^DGPT(IBPTF,0)),U,6)
- +27 IF '$$PTF(IBPTF)
- SET IB("SC")=IB("SC")+1
- QUIT
- +28 SET IB("NSC")=IB("NSC")+1
- +29 ;
- +30 ; - See if there is a claim for the NSC episode.
- +31 SET IBADM=+IBADMD\1
- +32 IF $$BILL(IBPTF,DFN,IBADM,IBDIS)
- SET IB("NSCB")=IB("NSCB")+1
- QUIT
- +33 ;
- +34 ; - Has episode been flagged as non-billable?
- +35 SET IBCT=$ORDER(^IBT(356,"AD",+$PIECE(IBPMD,U,14),0))
- +36 IF IBCT
- IF $PIECE($GET(^IBT(356,IBCT,0)),U,19)
- SET IB("NSCR")=IB("NSCR")+1
- QUIT
- +37 ;
- +38 SET IB("NSCU")=IB("NSCU")+1
- +39 SET IB("NSCU",IBSTAT)=IB("NSCU",IBSTAT)+1
- +40 IF IBRPT="D"
- Begin DoDot:3
- +41 SET X=$GET(^DPT(DFN,0))
- +42 SET ^TMP("IBJDI6",$JOB,$PIECE(X,U)_"@@"_DFN)=$PIECE(X,U,9)
- +43 SET ^TMP("IBJDI6",$JOB,$PIECE(X,U)_"@@"_DFN,IBADM)=$SELECT(IBSTAT=0:"OPEN",IBSTAT=1:"CLOSED",IBSTAT=2:"RELEASED",1:"TRANSMITTED")_U_IBDIS
- End DoDot:3
- End DoDot:2
- if IBQ
- QUIT
- End DoDot:1
- if IBQ
- QUIT
- +44 ;
- +45 IF IBQ
- GOTO ENQ
- +46 ;
- +47 ; Extract summary data.
- IF $GET(IBXTRACT)
- DO E^IBJDE(6,0)
- GOTO ENQ
- +48 ;
- +49 ; - Print the reports.
- +50 SET (IBPAG,IBQ)=0
- DO NOW^%DTC
- SET IBRUN=$$DAT2^IBOUTL(%)
- +51 IF IBRPT="D"
- DO DET
- +52 IF 'IBQ
- DO SUM
- +53 ;
- +54 IF 'IBQ
- DO PAUSE
- +55 ;
- ENQ KILL ^TMP("IBJDI6",$JOB)
- +1 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- GOTO ENQ1
- +2 ;
- +3 DO ^%ZISC
- ENQ1 KILL IB,IBQ,IBBDT,IBEDT,IBRPT,IBD,IBDN,IBPAG,IBRUN,IBX,IBX1,IBX2
- +1 KILL IBADM,IBDIS,IBCT,IBH,IBPER,IBPM,IBPMD,IBPMDT,IBPTF,IBSTAT,IBADMD
- +2 KILL %,%ZIS,DFN,POP,VA,VAERR,VAEL,X,Y,ZTDESC,ZTRTN,ZTSAVE
- +3 QUIT
- +4 ;
- DET ; - Print the detailed report.
- +1 DO HDET
- if IBQ
- QUIT
- +2 IF '$DATA(^TMP("IBJDI6",$JOB))
- Begin DoDot:1
- +3 IF IB("NSC")
- WRITE !!,"All NSC episodes for SC veterans in the selected date range have been billed."
- QUIT
- +4 WRITE !!,"There were no NSC episodes found in the selected date range."
- End DoDot:1
- GOTO DETQ
- +5 ;
- +6 SET IBX=""
- FOR
- SET IBX=$ORDER(^TMP("IBJDI6",$JOB,IBX))
- if IBX=""
- QUIT
- SET IBX1=^(IBX)
- Begin DoDot:1
- +7 SET (IBH,IBADM)=0
- FOR
- SET IBADM=$ORDER(^TMP("IBJDI6",$JOB,IBX,IBADM))
- if 'IBADM
- QUIT
- SET IBX2=^(IBADM)
- Begin DoDot:2
- +8 IF $Y>(IOSL-2)
- DO PAUSE
- if IBQ
- QUIT
- DO HDET
- if IBQ
- QUIT
- SET IBH=0
- +9 WRITE !
- IF 'IBH
- DO PAT
- SET IBH=1
- +10 WRITE ?46,$PIECE(IBX2,U),?59,$$DAT1^IBOUTL(IBADM),?69,$$DAT1^IBOUTL($PIECE(IBX2,U,2))
- End DoDot:2
- if IBQ
- QUIT
- End DoDot:1
- if IBQ
- QUIT
- +11 ;
- DETQ IF 'IBQ
- DO PAUSE
- +1 QUIT
- +2 ;
- PAT ; - Write the patient information.
- +1 WRITE $PIECE(IBX,"@@"),?32,$$SSN(IBX1)
- +2 QUIT
- +3 ;
- HDET ; - Write the detail report header.
- +1 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
- WRITE @IOF,*13
- +2 SET IBPAG=IBPAG+1
- +3 WRITE !,"Insured SC Vets w/ Unbilled NSC Care",?38,"Run Date: ",IBRUN,?70,"Page: ",IBPAG
- +4 WRITE !,"For Patients discharged in the period "_$$DAT1^IBOUTL(IBBDT)_" to "_$$DAT1^IBOUTL(IBEDT)
- +5 WRITE !,"Patient",?32,"SSN",?46,"PTF Status",?59,"Adm Date",?69,"Disc Date"
- +6 WRITE !,$$DASH(80)
- +7 SET IBQ=$$STOP^IBOUTL("SC Vets w/NSC Episodes")
- +8 QUIT
- +9 ;
- SUM ; - Print the summary report.
- +1 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
- WRITE @IOF,*13
- +2 SET IBPAG=IBPAG+1
- +3 WRITE !!?13,"INSURED SC VETERANS W/ UNBILLED NSC INPATIENT EPISODES"
- +4 WRITE !?33,"SUMMARY REPORT"
- +5 WRITE !!?16,"For Patients discharged from ",$$DAT1^IBOUTL(IBBDT)," - ",$$DAT1^IBOUTL(IBEDT)
- +6 WRITE !!?24,"Run Date: ",IBRUN,!?24,$$DASH(31),!!
- +7 ;
- +8 SET IBPER(1)=$SELECT('IB("TOT"):0,1:$JUSTIFY(IB("SC")/IB("TOT")*100,0,2))
- +9 SET IBPER(2)=$SELECT('IB("NSC"):0,1:$JUSTIFY(IB("NSCB")/IB("NSC")*100,0,2))
- +10 SET IBPER(3)=$SELECT('IB("NSC"):0,1:$JUSTIFY(IB("NSCR")/IB("NSC")*100,0,2))
- +11 WRITE ?9,"Number of Discharges of Insured SC Veterans:",?54,$JUSTIFY(IB("TOT"),4)
- +12 WRITE !?5,"Discharges Which were totally Service-Connected:",?54,$JUSTIFY(IB("SC"),4),?62,"(",IBPER(1),"%)"
- +13 WRITE !,"Discharges Which included Non-Service Connected Care:",?54,$JUSTIFY(IB("NSC"),4),?62,"(",$JUSTIFY($SELECT('IB("TOT"):0,1:100-IBPER(1)),0,2),"%)"
- +14 WRITE !?10,"Number of NSC Discharges Which were Billed:",?54,$JUSTIFY(IB("NSCB"),4),?62,"(",IBPER(2),"%)"
- +15 WRITE !?4,"Number of NSC Discharges Flagged as Non-Billable:",?54,$JUSTIFY(IB("NSCR"),4),?62,"(",IBPER(3),"%)"
- +16 WRITE !?19,"Number of Unbilled NSC Discharges:",?54,$JUSTIFY(IB("NSCU"),4),?62,"(",$JUSTIFY($SELECT('IB("NSC"):0,1:100-IBPER(2)-IBPER(3)),0,2),"%)",!?54,"----"
- +17 FOR X=0:1:3
- Begin DoDot:1
- +18 IF X=0
- WRITE !,"Unbilled NSC Discharges w/ PTF Status of"
- +19 WRITE ?41,$SELECT(X=0:"Open",X=1:"Closed",X=2:"Released",1:"Transmitted"),":",?54,$JUSTIFY(IB("NSCU",X),4),?62,"(",$JUSTIFY($SELECT('IB("NSCU",X):0,1:IB("NSCU",X)/IB("NSCU")*100),0,2),"%)",!
- End DoDot:1
- +20 QUIT
- +21 ;
- DASH(X) ; - Return a dashed line.
- +1 QUIT $TRANSLATE($JUSTIFY("",X)," ","=")
- +2 ;
- PAUSE ; - Page break.
- +1 IF $EXTRACT(IOST,1,2)'="C-"
- QUIT
- +2 NEW IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
- +3 FOR IBX=$Y:1:(IOSL-3)
- WRITE !
- +4 SET DIR(0)="E"
- DO ^DIR
- IF $DATA(DIRUT)!($DATA(DUOUT))
- SET IBQ=1
- +5 QUIT
- +6 ;
- SSN(X) ; - Format the SSN.
- +1 QUIT $SELECT(X]"":$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,10),1:"")
- +2 ;
- PTF(IBPTF) ; - Does the PTF record have an NSC-related movement?
- +1 ; Input: IBPTF = Pointer to the PTF record in file #45
- +2 ; Output: IBNSC = 1 (NSC movement) or 0 (No NSC movement)
- +3 ;
- +4 NEW IBNSC,X,Y
- +5 SET (IBNSC,X)=0
- +6 IF '$GET(IBPTF)
- GOTO PTFQ
- +7 ;
- +8 ; - Check PTF movements for a movement not related to SC care.
- +9 FOR
- SET X=$ORDER(^DGPT(IBPTF,"M",X))
- if 'X
- QUIT
- SET Y=$PIECE($GET(^(X,0)),U,18)
- IF Y'=1
- SET IBNSC=1
- QUIT
- +10 ;
- PTFQ QUIT IBNSC
- +1 ;
- BILL(IBPTF,DFN,IBADM,IBDIS) ; - Has this episode of care been billed?
- +1 ; Input: IBPTF = Pointer to the PTF record in file #45
- +2 ; DFN = Pointer to the patient in file #2
- +3 ; IBADM = Episode admission date
- +4 ; IBDIS = Episode discharge date
- +5 ; Output: BILL = 1 (Episode has been billed)
- +6 ; 0 (Episode has not been billed)
- +7 ;
- +8 NEW BILL,X,X1,XU,Y
- +9 SET BILL=0
- +10 ;
- +11 ; - See if there is a claim based on the PTF record.
- +12 IF $GET(IBPTF)
- Begin DoDot:1
- +13 SET X=0
- FOR
- SET X=$ORDER(^DGCR(399,"APTF",IBPTF,X))
- if 'X
- QUIT
- SET Y=$PIECE($GET(^DGCR(399,X,0)),U,13)
- IF Y
- IF Y<7
- SET BILL=1
- QUIT
- End DoDot:1
- if BILL
- GOTO BILLQ
- +14 ;
- +15 ; - Check other inpatient bills for care provided in the adm/dis period.
- +16 SET X=0
- FOR
- SET X=$ORDER(^DGCR(399,"C",+$GET(DFN),X))
- if 'X
- QUIT
- Begin DoDot:1
- +17 SET X1=$GET(^DGCR(399,X,0))
- SET XU=$GET(^("U"))
- if X1=""
- QUIT
- +18 ; Outpatient care.
- IF $PIECE(X1,U,5)>2
- QUIT
- +19 ; Bill is cancelled.
- IF $PIECE(X1,U,13)=7
- QUIT
- +20 ; Care outside of range.
- IF +XU\1<IBADM!($PIECE(XU,U,2)\1>IBEDT)
- QUIT
- +21 SET BILL=1
- End DoDot:1
- if BILL
- QUIT
- +22 ;
- BILLQ QUIT BILL
