source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF4.m@ 1000

Last change on this file since 1000 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version
File size: 4.8 KB
RevLine 
[623]1IBCF4 ;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 ;
5PRXA ;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 ;
20DEV ;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 ;
26EXIT ;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 ;
31EN ;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
34RX 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 ;
51PROS 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
61END K IBX,IBY,IBPGN,IBRX,IBHDR,IBRIFN,IBLN,IBCDT,IBI,IBXREF,IBPI,IBPIFN,IBRC,IBYC
62 Q
63 ;
64CHG(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 ;
73HDR ;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 ;
83PAUSE ;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 ;
89STOP() ;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 ;
93RXDISP ;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 ;
101DATE(X) Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
102 ;
103BILLAD(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 TracBrowser for help on using the repository browser.