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

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

initial load of WorldVistAEHR

File size: 7.2 KB
Line 
1IBCSC5C ;ALB/ARH - ADD/EDIT PRESCRIPTION FILLS (CONTINUED) ;3/4/94
2 ;;2.0;INTEGRATED BILLING;**27,52,130,51,160,260,309,315,339,347,363,381**;21-MAR-94;Build 1
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;
6DEFAULT(IFN,IBRX) ; add default DX and CPT to a prescription bill
7 ; if one is not in PSO. If there is, use it instead.
8 ; IFN = ien of bill entry
9 N IBX,IBPAR1,IBDX,IBCPT,IBDT,IBBIL,IBDXIFN,IBCPTIFN,IBY,IB52,IBC,PDFN,LIST,NODE
10 S IBDXIFN=0
11 S IBPAR1=$G(^IBE(350.9,1,1)),IBDX=$P(IBPAR1,U,29),IBCPT=$P(IBPAR1,U,30)
12 S IBBIL=$G(^DGCR(399,+$G(IFN),0)) Q:IBBIL=""
13 S IBX=$S($G(IBRX):$P($G(^DGCR(399,IFN,"RC",+IBRX,0)),U,11),1:$O(^IBA(362.4,"C",IFN,0))) Q:'IBX
14 S IB52=+$P($G(^IBA(362.4,IBX,0)),"^",5),IBY=0 Q:IB52=0
15 S PDFN=$$FILE^IBRXUTL(IB52,2)
16 S LIST="IBCSC5CARR"
17 S NODE="ICD"
18 D RX^PSO52API(PDFN,LIST,IB52,,NODE,,)
19 I ^TMP($J,LIST,PDFN,IB52,"ICD",0)>0 D
20 .S IBY=0 F S IBY=$O(^TMP($J,LIST,PDFN,IB52,"ICD",IBY)) Q:IBY'>0 D
21 ..S IBDX(IBY)=$$ICD^IBRXUTL1(PDFN,IB52,IBY,LIST)
22 ..I 'IBDX(IBY) K IBDX(IBY)
23 K ^TMP($J,LIST)
24 I 'IBDX,'IBCPT,$D(IBDX)<10 Q
25 S IBDT=$P($G(^IBA(362.4,+IBX,0)),U,3) Q:'IBDT
26 ; add dx associated with rx if they are there.
27 I $D(IBDX)>9 S (IBC,IBDX,IBY)=0 F S IBY=$O(IBDX(IBY)) Q:'IBY D
28 . I $D(^IBA(362.3,"AIFN"_IFN,+IBDX(IBY))) Q
29 . S IBC=IBC+1
30 . S DIC="^IBA(362.3,",DIC(0)="L",DIC("DR")=".02////"_IFN_";.03////"_IBC,X=+IBDX(IBY),DLAYGO=362.3
31 . K DD,DO D FILE^DICN K DIC,DA,DR,DD,DO,DLAYGO
32 . S IBDXIFN(IBC)=+Y
33 ; add default dx if none found on actual rx.
34 I +IBDX,'$D(^IBA(362.3,"AIFN"_IFN,+IBDX)) S DIC="^IBA(362.3,",DIC(0)="L",DIC("DR")=".02////"_IFN,X=IBDX,DLAYGO=362.3 K DD,DO D FILE^DICN K DIC,DA,DR,DD,DO,DLAYGO S IBDXIFN=+Y
35 I +IBCPT D ;Check if the procedure is already present for the Rx
36 . N Z,Z0,DUP
37 . S (DUP,Z)=0 F S Z=$O(^DGCR(399,IFN,"RC",Z)) Q:'Z S Z0=$G(^(Z,0)) D Q:DUP
38 .. I $P(Z0,U,10)=3,$P(Z0,U,15),$P(Z0,U,11)=IBX S DUP=1
39 . Q:DUP
40 . I $P($G(^DGCR(399,IFN,0)),U,9)="" S DIE="^DGCR(399,",DA=IFN,DR=".09////5" D ^DIE K DIE,DIC,DA,DR
41 . I '$D(^DGCR(399,IFN,"CP",0)) S DIC("P")=$$GETSPEC^IBEFUNC(399,304)
42 . S DLAYGO=399,DIC("DR")="1////"_IBDT D
43 . . I +IBDXIFN>0 S DIC("DR")=DIC("DR")_";10////"_IBDXIFN Q
44 . . I $D(IBDXIFN)>9 F IBY=1:1:4 I $D(IBDXIFN(IBY)) S DIC("DR")=DIC("DR")_";"_(IBY+9)_"////"_IBDXIFN(IBY)
45 . S DIC="^DGCR(399,"_IFN_",""CP"",",DIC(0)="L",DA(1)=IFN,X=IBCPT_";ICPT(" K DD,DO D FILE^DICN K DIC,DA,DD,DO,DR,DLAYGO
46 . I +Y D
47 .. N Z,IBZ
48 .. S IBZ=+Y,Z=$S($G(IBREV):IBREV,1:$$FINDREV^IBCSC5A(IFN,3,+IBX))
49 .. I Z S DR=".15////"_IBZ_";.06////"_IBCPT,DA=+Z,DA(1)=IFN,DIE="^DGCR(399,"_DA(1)_",""RC""," D ^DIE
50 Q
51 ;
52RXDISP(DFN,DT1,DT2,ARRAY,POARR,RXARR,IBRXALL,NODISP) ; display all rx fills for a patient and date range
53 ;RXARR (as defined by SET^IBCSC5A) passed by ref. only to check if rx-fill is on the bill, not necessary not changed
54 ;returns: ARRAY(RX #, FILL DT) = RX IFN (52) ^ FILL IFN ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC, pass by reference if desired
55 ; POARR(CNT)=RX # ^ FILL DT
56 N PIFN,RIFN,IBX,IBY,DTE,DTR,RX,IBCNT,IBRX0,IBRX2,IBS,LIST,LIST2 K ARRAY,POARR S POARR=0,NODISP=+$G(NODISP)
57 S IBCNT=0,DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 Q:'$G(DFN)
58 ;^PS(55,DFN,"P","A",EXPIRATION DATE, RX) is the best xref available for finding patient fills in a date range
59 ;if RX expires/cancelled before start of bill then should not be applicable to bill
60 S LIST="IBRXDISPARR"
61 D PROF^PSO52API(DFN,LIST,DT1)
62 S DTE=0 F S DTE=$O(^TMP($J,LIST,"B",DTE)) Q:'DTE D
63 . S PIFN=0 F S PIFN=$O(^TMP($J,LIST,"B",DTE,PIFN)) Q:'PIFN D
64 .. S IBRX0=$$RXZERO^IBRXUTL(DFN,PIFN),IBRX2=$$RXSEC^IBRXUTL(DFN,PIFN)
65 .. ; original fill
66 .. I +$G(IBRXALL) S DTR=$P(IBRX2,U,2) I DTR'<DT1,DTR'>DT2 D
67 ... D DATA^IBRXUTL(+$P(IBRX0,U,6))
68 ... S ARRAY($P(IBRX0,U,1),+DTR)=PIFN_U_0_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBRX0,U,7)_U_$$GETNDC^PSONDCUT(PIFN,0)
69 ... K ^TMP($J,"IBDRUG")
70 ... Q
71 .. ; refills
72 .. S LIST2="IBDISPSUB"
73 .. S NODE="R"
74 .. D RX^PSO52API(DFN,LIST2,PIFN,,NODE,,)
75 .. S RIFN=0 F S RIFN=$O(^TMP($J,LIST2,DFN,PIFN,"RF",RIFN)) Q:RIFN'>0 D
76 ... S IBY=$$ZEROSUB^IBRXUTL(DFN,PIFN,RIFN) Q:IBY=""
77 ... Q:+IBY<DT1!(+IBY>DT2)
78 ... D DATA^IBRXUTL(+$P(IBRX0,U,6))
79 ... S ARRAY($P(IBRX0,U,1),+IBY)=PIFN_U_RIFN_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBY,U,4)_U_$$GETNDC^PSONDCUT(PIFN,RIFN)
80 ... K ^TMP($J,"IBDRUG")
81 ... Q
82 .. K ^TMP($J,LIST2)
83 K ^TMP($J,LIST)
84 ;
85 S IBX="",IBS=0 F S IBX=$O(ARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(ARRAY(IBX,IBY)) Q:'IBY D
86 . S IBCNT=IBCNT+1,POARR(IBCNT)=$P(IBX,U,1)_"^"_+IBY,POARR=IBCNT I $D(RXARR(IBX,IBY)) S IBS=IBS+1
87 S $P(POARR,U,2)=IBCNT-IBS
88 ;
89 Q:+NODISP
90 W @IOF,?33,"PRESCRIPTIONS IN DATE RANGE",!,"===============================================================================",!
91 S IBCNT=0 F S IBCNT=$O(POARR(IBCNT)) Q:IBCNT="" S RX=$P(POARR(IBCNT),U,1),DTR=$P(POARR(IBCNT),U,2) I RX'="",DTR'="" D
92 . S IBS=$$RXSTAT^IBCU1($P(ARRAY(RX,DTR),U,3),$P(ARRAY(RX,DTR),U,1),DTR)
93 . S IBY="" I $D(RXARR(RX,+DTR)) S IBY="*"
94 . D ZERO^IBRXUTL(+$P(ARRAY(RX,DTR),U,3))
95 . W !,$J(IBCNT,2),")",?5,IBY,?6,RX,?19,$E($G(^TMP($J,"IBDRUG",+$P(ARRAY(RX,DTR),U,3),.01)),1,25),?46,$$DATE(+DTR),?56,$P(IBS,U,1),?61,$P(IBS,U,2),?69,$P(IBS,U,3),?75,$$EXEMPT(+ARRAY(RX,DTR))
96 . S IBY=$$RXDUP^IBCU3(RX,DTR,IBIFN) I +IBY W ?73,$P($G(^DGCR(399,+IBY,0)),U,1)
97 . K ^TMP($J,"IBDRUG")
98 Q
99DATE(X) Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
100 ;
101NEWRX(IBX) ;
102 Q:'$G(IBX) N X,Y K IBLIST W !
103NEWRX1 S DIR("?")="Enter the number preceding the RX Fills you want added to the bill. "_$$HTEXT
104 S DIR("A")="SELECT NEW RX FILLS TO ADD THE BILL"
105 S DIR(0)="LO^1:"_+IBX D ^DIR K DIR G:'Y!$D(DIRUT) NEWRXE
106 S IBLIST=Y
107 ;
108 S DIR("A")="YOU HAVE SELECTED "_IBLIST_" TO BE ADDED TO THE BILL IS THIS CORRECT",DIR("B")="YES"
109 S DIR(0)="YO" D ^DIR K DIR I $D(DIRUT) K IBLIST G NEWRXE
110 I 'Y K IBLIST G NEWRX1
111NEWRXE Q
112 ;
113ADDNEW(IBIFN,LIST,IBPR,IBPRO) ;
114 Q:'LIST N IBI,IBX,IBRX,IBDT,IBQ,IBY,IBPIFN,IBZ
115 F IBI=1:1 S IBX=$P(LIST,",",IBI) Q:'IBX I $D(IBPRO(IBX)) D
116 . S IBRX=$P(IBPRO(IBX),U,1),IBDT=$P(IBPRO(IBX),U,2) Q:IBRX=""
117 . S IBQ=0,IBY=$G(IBPR(IBRX,+IBDT)) Q:'IBY
118 . S IBPIFN=0 F S IBPIFN=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX,IBPIFN)) Q:'IBPIFN I $P($G(^IBA(362.4,IBPIFN,0)),U,3)=IBDT S IBQ=1 Q
119 . I 'IBQ S IBZ=$G(IBPR(IBRX,IBDT)) I $$ADD^IBCSC5A(IBRX,IBIFN,IBDT,$P(IBZ,U,3),$P(IBZ,U,1),$P(IBZ,U,4,6)) W "."
120 Q
121 ;
122HTEXT() ;
123 N X S X="If an Rx fill has been assigned to another bill it will be displayed in the last column. [ORG=Original Fill, NR=Not Released, RTS=Returned to Stock, OTC=Over-the-Counter, INV=Investigational, SUP=Supply Item]"
124 Q X
125 ;
126RXLINK(IBIFN,CPIEN) ; Function returns the ien of the Rx rev code the proc
127 ; code is linked to or 0 if no link found.
128 Q +$O(^DGCR(399,IBIFN,"RC","ACP",+CPIEN,0))
129 ;
130EXEMPT(RX) ; Used to look up exemption if any on rx, the return value
131 ; will be only the first exemption reason found.
132 N IBX,IBZ,IBS,IBR,PDFN,LIST,NODE,ICDCT
133 S PDFN=$$FILE^IBRXUTL(RX,2)
134 S LIST="IBRXARREX"
135 S NODE="ICD"
136 D RX^PSO52API(PDFN,LIST,RX,,NODE,,)
137 S ICDCT=$G(^TMP($J,LIST,PDFN,RX,"ICD",0))
138 S IBR="",(IBS,IBX)=0
139 I ICDCT>0 D
140 .S IBX=0 F S IBX=$O(^TMP($J,LIST,PDFN,RX,"ICD",IBX)) Q:IBX'>0!(IBS) D
141 ..S IBZ=$$ICD^IBRXUTL1(PDFN,RX,IBX,LIST) F IBP=2:1:8 Q:IBS I $P(IBZ,"^",IBP) S IBR=$P($T(EREASON+(IBP-1)),";",3),IBS=1
142 K ^TMP($J,LIST)
143 Q IBR
144EREASON ;
145 ;;AO
146 ;;IR
147 ;;SC
148 ;;SWA
149 ;;MST
150 ;;HNC
151 ;;CV
152 ;;SHAD
153 ;
Note: See TracBrowser for help on using the repository browser.