- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF4.m
r613 r623 1 IBCF4 2 ;;2.0;INTEGRATED BILLING;**52,137,199,309,389**;21-MAR-94;Build 6 3 ;;Per VHA Directive 2004-038, this routine should not be modified.4 5 PRXA 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 DEV 21 22 23 24 25 26 EXIT 27 28 29 30 31 EN 32 33 34 RX 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 PROS 52 53 54 55 56 57 58 . W !,$$FMTE^XLFDT(+$P(IBY,U,1),2),?11,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?24,$E($P(IBY,U,5),1,55)59 60 61 END 62 63 64 CHG(IBY,IBTYP,IBRC) 65 66 67 68 69 70 71 72 73 HDR 74 75 76 77 78 79 80 81 82 83 PAUSE 84 85 86 87 88 89 STOP() 90 91 92 93 RXDISP 94 95 96 97 98 99 100 101 DATE(X) 102 103 BILLAD(IFN) 104 105 1 IBCF4 ;ALB/ARH - PRINT BILL ADDENDUM ;12-JAN-94 2 ;;2.0;INTEGRATED BILLING;**52,137,199,309**;21-MAR-94 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 PRXA ;get bill number then print rx refill addendums for bills 6 S DIC("S")="I $D(^IBA(362.4,""AIFN""_+Y))!($D(^IBA(362.5,""AIFN""_+Y)))" 7 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups 8 S DIC="^DGCR(399,",DIC(0)="AEMQ" D ^DIC K DIC G:+Y'>0 EXIT S IBBILL=$P(Y,U,2),IBIFN=+Y 9 ; 10 I $D(^IBA(364,"ABDT",IBIFN)),+$$TXMT^IBCEF4(IBIFN)=1 D G:'IBTXOK PRXA 11 .S IBTXOK=0 12 .N IBLDT,IBX 13 .S IBLDT=$O(^IBA(364,"ABDT",IBIFN,""),-1),IBX=$O(^IBA(364,"B",IBIFN,+IBLDT,""),-1) 14 .I "X"[$P($G(^IBA(364,+IBX,0)),U,3) W !!,*7,"Transmittable Bill can NOT be printed until transmitted" Q 15 .W !!,"This is a Transmittable Bill that has already been transmitted" 16 .W !!,"WANT TO PRINT THIS BILL ADDENDUM ANYWAY" S %=2 D YN^DICN 17 .Q:'(%+1#3) ;-1 or 2 18 .S IBTXOK=1 19 ; 20 DEV ;get the device 21 W !!,"Report requires 132 columns." 22 S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT 23 I $D(IO("Q")) S ZTRTN="EN^IBCF4",ZTDESC="BILL ADDENDUM FOR "_IBBILL,ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q"),ZTSK G EXIT 24 U IO D EN 25 ; 26 EXIT ;clean up and quit 27 I $D(ZTQUEUED) S ZTREQ="@" Q 28 K IBQUIT,IBIFN,IBBILL,IBTXOK,X,Y,DTOUT,DUOUT,DIRUT,DIROUT D ^%ZISC 29 Q 30 ; 31 EN ;ENTRY POINT IF QUEUED, print all rx refills for a bill 32 S IBY=$G(^DGCR(399,+IBIFN,0)) Q:IBY="" S IBXREF="AIFN"_IBIFN 33 S (IBQUIT,IBPGN,IBRX)=0,IBHDR="BILL ADDENDUM FOR "_$P($G(^DPT(+$P(IBY,U,2),0)),U,1)_" - "_$P(IBY,U,1) D HDR 34 RX I '$D(^IBA(362.4,IBXREF)) G PROS 35 W !!,"PRESCRIPTION REFILLS:",! 36 K IBRC 37 D RCITEM^IBCSC5A(IBIFN,"IBRC",3) 38 S IBRX=0 F S IBRX=$O(^IBA(362.4,IBXREF,IBRX)) Q:IBRX=""!IBQUIT S IBRIFN=0 F S IBRIFN=$O(^IBA(362.4,IBXREF,IBRX,IBRIFN)) Q:'IBRIFN!IBQUIT D 39 .S IBY=$G(^IBA(362.4,IBRIFN,0)) Q:IBY="" 40 .S IBYC=$$CHG(IBRIFN,3,.IBRC) 41 .; 42 . D ZERO^IBRXUTL(+$P(IBY,U,4)) 43 . W !,$P(IBY,U,1),?13,$$FMTE^XLFDT(+$P(IBY,U,3),2),?22,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?34,$G(^TMP($J,"IBDRUG",+$P(IBY,U,4),.01)) 44 . K ^TMP($J,"IBDRUG") 45 . I $P(IBY,U,6)'="" W ?77,"QTY: ",$P(IBY,U,7) 46 . I $P(IBY,U,7)'="" W ?87,"DAYS SUPPLY: ",$P(IBY,U,6) 47 . I $P(IBY,U,8)'="" W ?105,"NDC #: ",$P(IBY,U,8) 48 . S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR 49 K IBRC 50 ; 51 PROS I '$D(^IBA(362.5,IBXREF)) G END 52 W !!!,"PROSTHETIC ITEMS:",! 53 K IBRC 54 D RCITEM^IBCSC5A(IBIFN,"IBRC",5) 55 S IBPI=0 F S IBPI=$O(^IBA(362.5,IBXREF,IBPI)) Q:IBPI=""!IBQUIT S IBPIFN=0 F S IBPIFN=$O(^IBA(362.5,IBXREF,IBPI,IBPIFN)) Q:'IBPIFN!IBQUIT D 56 . S IBY=$G(^IBA(362.5,IBPIFN,0)),IBYC="" Q:IBY="" 57 . S IBYC=$$CHG(IBPIFN,5,.IBRC) 58 . W !,$$FMTE^XLFDT(+$P(IBY,U,1),2),?11,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?24,$P($$PIN^IBCSC5B(+$P(IBY,U,3)),U,2) 59 . S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR 60 D:'IBQUIT PAUSE 61 END K IBX,IBY,IBPGN,IBRX,IBHDR,IBRIFN,IBLN,IBCDT,IBI,IBXREF,IBPI,IBPIFN,IBRC,IBYC 62 Q 63 ; 64 CHG(IBY,IBTYP,IBRC) ; Return charge for item entry IBY or null if no charge 65 ; IBRC = the array containing the revenue code items and their units and charges 66 ; IBTYP = the type of item being priced 67 N IBZ,IBYC 68 S IBRC=$S($D(IBRC(IBTYP,IBY)):IBY,1:0),IBYC="" 69 F IBRC=IBRC,0 Q:'$D(IBRC(IBTYP,IBRC)) S IBZ="" D Q:IBZ'=""!(IBRC=0) 70 .F S IBZ=$O(IBRC(IBTYP,IBRC,IBZ)) Q:IBZ="" I IBRC(IBTYP,IBRC,IBZ) S $P(IBRC(IBTYP,IBRC,IBZ),U)=IBRC(IBTYP,IBRC,IBZ)-1,IBYC=$P(IBRC(IBTYP,IBRC,IBZ),U,2) K:'IBRC(IBTYP,IBRC,IBZ) IBRC(IBTYP,IBRC,IBZ) Q 71 Q IBYC 72 ; 73 HDR ;print the report header 74 S IBQUIT=$$STOP Q:IBQUIT S IBPGN=IBPGN+1,IBLN=5 75 D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S IBCDT=$P(Y,"@",1)_" "_$P(Y,"@",2) 76 I IBPGN>1!($E(IOST,1,2)["C-") W @IOF 77 W IBHDR W:IOM<85 ! W ?(IOM-30),IBCDT,?(IOM-8),"PAGE ",IBPGN,! 78 ;W !,"RX #",?13,"REFILL DATE",?28,"DRUG",?70,"DAYS SUPPLY",?83,"QTY",?90,"NDC #",! 79 F IBI=1:1:IOM W "-" 80 W ! 81 Q 82 ; 83 PAUSE ;pause at end of screen if being displayed on a terminal 84 Q:$E(IOST,1,2)'["C-" 85 S DIR(0)="E" D ^DIR K DIR 86 I $D(DUOUT)!($D(DIRUT)) S IBQUIT=1 87 Q 88 ; 89 STOP() ;determine if user has requested the queued report to stop 90 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***" 91 Q +$G(ZTSTOP) 92 ; 93 RXDISP ;displays all rx refills bills 94 ;N IBX,IBY,IBZ,IBC,X,Y S Y=1,IBC=0,IBX="AIFN" 95 ;F S IBX=$O(^IBA(362.4,IBX)) Q:IBX="" S IBY=$E(IBX,5,999),IBZ=$G(^DGCR(399,+IBY,0)) I IBZ'="" D Q:'Y 96 ;. W !,$P(IBZ,U,1),?10,$E($P($G(^DPT(+$P(IBZ,U,2),0)),U,1),1,20),?32,$$DATE(+$P(IBZ,U,3)),?42,$S(+$P(IBZ,U,5)<3:"INPT",1:"OUTPT") 97 ;. W ?49,$P($G(^DGCR(399.3,+$P(IBZ,U,7),0)),U,4),?59,$E($$EXSET^IBEFUNC(+$P(IBZ,U,13),399,.13),1,7),?68,$E($P($G(^IBE(353,+$P(IBZ,U,19),0)),U,1),1,11) 98 ;. S IBC=IBC+1 I '(IBC#10) S DIR(0)="E" D ^DIR K DIR 99 ;Q 100 ; 101 DATE(X) Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) 102 ; 103 BILLAD(IFN) ;returns true if bill has either rx refills or prosthetics so addendum should print 104 N IBX S IBX=0,IFN=+$G(IFN) S:+$O(^IBA(362.4,"AIFN"_IFN,0)) IBX=1 S:+$O(^IBA(362.5,"AIFN"_IFN,0)) IBX=IBX+2 105 Q IBX
Note:
See TracChangeset
for help on using the changeset viewer.
