source: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPIBC.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1PSOCPIBC ;BHAM ISC/EJW - PHARMACY CO-PAY APPLICATION UTILITIES FOR IB ; 01/15/02
2 ;;7.0;OUTPATIENT PHARMACY;**93**;DEC 1997
3 ;External references to IBARX is supported by DBIA 125
4 ;External reference to PSDRUG( is supported by DBIA 221
5 ;This routine is called by PSOCPIBF to attempt to bill for released CMOP copays.
6 ;For Rx fills with a release date prior to 01/01/02 this routine is called instead of CP^PSOCP. This routine does not check the additional
7 ;exemption questions and does not send a MailMan message if an exemption question has not been answered.
8CP ; Entry point to Check if COPAY - Requires RXP,PSOSITE7
9 I '$D(PSOPAR) D ^PSOLSET G CP
10 K PSOCP
11 ; Q:'$D(^PSRX(RXP,"IB")) Q:"12"'[$E(+^PSRX(RXP,"IB"))
12 S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT
13 S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type
14 S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status
15 ; Set x=service^dfn^actiontype^user duz
16 I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
17 S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16)
18 ;
19RX ; Determine Original or Refill for RX
20 S PSOREF=0
21 I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY
22 ; Check if bill # already exists for this RX or Refill
23 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 G QUIT
24 I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) G QUIT
25 S PSOCHG=1 ; set temporary variable to copay and then look for exceptions
26 N MAILMSG
27 D COPAYREL
28 I 'PSOCHG D G QUIT
29 . I PSOSAVE S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA S $P(^PSRX(RXP,"IB"),"^",1)=""
30 I PSOCHG=2 D I 'PSOCP G QUIT ; IF 'SC' QUESTION APPLIES, BUT HAS NOT BEEN ANSWERED, SEND MAIL MSG AND KEEP COPAY STATUS AS IT WAS
31 . ; D MAIL2^PSOCPE ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF THE PSO COPAY KEY
32 I PSOCHG=1,PSOSAVE="" D I PSOREF S PSOCOMM="",PSOOLD="No Copay",PSONW="Copay" S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA
33 . I '$D(^PSRX(RXP,"IB")),'PSOREF S $P(^PSRX(RXP,"IB"),"^",1)=1 Q
34 . S $P(^PSRX(RXP,"IB"),"^",1)=1
35 . S PSOCP=1,$P(X,"^",3)=PSOCP
36 I PSOCHG'=2 I $G(MAILMSG) ; D MAIL2^PSOCPE ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF PSO COPAY KEY
37 ; Units for COPAY
38 S PSOCPUN=$P(($P(^PSRX(RXP,0),"^",8)+29)/30,".",1)
39 ; Build softlink for x(n)=softlink^units
40 S X(1)="52:"_RXP S:PSOREF>0 X(1)=X(1)_";1:"_PSOREF S X(1)=X(1)_"^"_PSOCPUN
41 ; Set correct user duz if refill
42 I PSOREF S:+$P(^PSRX(RXP,1,PSOREF,0),"^",7)>0 $P(X,"^",4)=$P(^PSRX(RXP,1,PSOREF,0),"^",7)
43 ;
44IBNEW ; Load ^TMP global for IB call
45 Q:$G(RXP)'>0
46 N D0
47 G QUIT:'$D(X)
48 S XTMP=X,XTMP(1)=X(1)
49 ;
50 ; Requires x=service^dfn^action type^user duz
51 ; x(n)=softlink^units
52 I $P(X,"^",3)="" S $P(X,"^",3)=$P(^PSRX(RXP,"IB"),"^",1)
53 D NEW^IBARX
54 ; Returns y=1^total charges for this group or Y=-1^error code
55 ; y(n)=IB number^charge for this Rx^AR bill #^Cap met^Partial or Full charge^Copay Exempt^Number from file 354.71
56 ; Cap met ('1' - If patient has met cap amount or
57 ; reached cap with this charge or '0' if not)
58 ; Partial or Full ('P' for partial billing, 'F' for
59 ; full billing, null for no billing)
60 ; Copay Exempt - ('1' for exempt, '0' for non-exempt,
61 ; '-1' for copay off (manila))
62 ; ('1' - If patient has met cap amount or reach cap with this charge
63 ; Entry from file 354.71 will only be saved for fills that met the annual cap and could not be fully billed
64 ;
65 G QUIT:+Y=-1
66 S XTMP=XTMP_"^"_Y,XTMP(1)=XTMP(1)_"^"_Y(1)
67 ;
68 ; see if exempt or copay cap was met for this fill
69 I $P(Y(1),"^",6) D G QUIT
70 . S PREA="R",PSOOLD="Copay",PSONW="No Copay"
71 . S PSOCOMM="RX COPAY INCOME EXEMPTION" S PSODA=RXP D ACTLOG^PSOCPA
72 . S $P(^PSRX(RXP,"IB"),"^",1)=""
73 I $P(Y(1),"^",4) D
74 . S PSOCOMM=$S($P(Y(1),"^",5)="F":" FULL BILLING FOR THIS FILL",$P(Y(1),"^",5)="P":" PARTIAL BILLING FOR THIS FILL ",1:" NO BILLING FOR THIS FILL")
75 . S PREA="A"
76 . S PSODA=RXP D ACTLOG^PSOCPA
77 . I $P(Y(1),"^",5)'="F" D
78 . . I PSOREF S $P(^PSRX(RXP,1,PSOREF,"IB"),"^",2)=$P(Y(1),"^",7) Q
79 . . S $P(^PSRX(RXP,"IB"),"^",4)=$P(Y(1),"^",7)
80 I $P(Y(1),"^",1)="" G QUIT
81 ;
82FILE ; File IB number in ^PSRX
83 S PSOCP2=0
84 S PSOCP2=+$P(XTMP(1),":",3)
85 S:PSOCP2>0 ^PSRX(RXP,1,PSOCP2,"IB")=$P(XTMP(1),U,3) ; Filing in refill node
86 I PSOCP2>0,'$D(^PSRX(RXP,"IB")) S ^PSRX(RXP,"IB")="1^^" ; If refill "IB" exists, need "IB" entry on original fill node
87 S:PSOCP2=0 $P(^PSRX(RXP,"IB"),"^",2)=$P(XTMP(1),U,3) ;Filing in original fill (zero node)
88QUIT ;
89 K Y,PSOCP1,PSOCP2,QQ,PSOCPN,X,X2,XTMP,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PSOCOMM,PSOOLD,PSONW,PREA,PSORSN
90 Q
91EN D ^PSOLSET
92EN1 S DIR(0)="NO",DIR("A")="Enter PRESCRIPTION number" D ^DIR K DIR G:$D(DIRUT) EXIT S RXP=X I +$G(^PSRX(RXP,0))'>0!+$P($G(^PSRX(RXP,"IB")),"^",0)>0 W !,?10,"RE-CHECK PRESCRIPTION NUMBER AND RE-ENTER " G EN1
93 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
94 S PSODFN=$P(^PSRX(RXP,0),"^",2)
95 D CP G EN1
96EXIT K RXP D FINAL^PSOLSET Q
97 ;
98COPAYREL ; Recheck copay status at release
99 ;
100 ; check Rx patient status
101 I $P(^PSRX(RXP,0),"^",3)'="",$P($G(^PS(53,$P(^PSRX(RXP,0),"^",3),0)),"^",7)=1 S PSOCHG=0,PSOCOMM="Rx Patient Status Change",PSOOLD="Copay",PSONW="No Copay" Q
102 ; see if drug is investigational or supply
103 N DRG,DRGTYP
104 S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3)
105 I DRGTYP["I" S PSOCOMM="Investigational Drug",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0 Q
106 I DRGTYP["S" S PSOCOMM="Supply Item",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0 Q
107 K PSOTG
108 N EXMT
109 D XTYPE
110 F EXMT="SC" I $D(PSOTG(EXMT)) D I 'PSOCHG Q
111 . I PSOTG(EXMT)=1 S PSOCHG=0 S PSOCOMM="Service Connected"
112 I 'PSOCHG S PSOOLD="Copay",PSONW="No Copay" Q
113 ;
114 ; If any of the applicable exemption questions have never been answered, generate a mail message with all of the questions
115 S EXMT="",MAILMSG=0 F S EXMT=$O(PSOTG(EXMT)) Q:EXMT="" I PSOTG(EXMT)="" S MAILMSG=1 Q
116 I MAILMSG,$D(PSOTG("SC")) I $G(PSOTG("SC"))="" S PSOCHG=2 ; 'SC' question not answered, don't reset copay status to 'copay'
117 Q
118 ;
119XTYPE ;
120 N PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY
121 S (X,PSOSCMX,SAVY)=""
122 S PSOCIBQ=$G(^PSRX(RXP,"IBQ"))
123 I $P(PSOCIBQ,"^",1)'="" S PSOTG("SC")=$P(PSOCIBQ,"^",1)
124 I $D(PSOTG("SC")),$P(PSOCIBQ,"^",1)="" S PSOTG("SC")="" ; USE "CURRENT" SETTING AS ANSWER TO SERVICE CONNECTED QUESTION IF IT APPLIES
125 S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q
126 I 'X Q
127 S X=X_"^"_PSOCPN D XTYPE^IBARX
128 I $G(Y)'=1 Q
129 S J="" F S J=$O(Y(J)) Q:'J S I="" F S SAVY=I,I=$O(Y(J,I)) Q:I="" S:I>0 PSOSCMX=I
130 I PSOSCMX="",SAVY=0 S PSOCHG=0 S PSOCOMM="Exempt from copayment" Q ; INCOME EXEMPT OR SERVICE-CONNECTED
131 I PSOSCMX=2,'$D(PSOTG("SC")) S PSOTG("SC")=$S(($G(RXP)&($P($G(^PSRX(+$G(RXP),"IB")),"^")))!($P(PSOCIBQ,"^")=0):0,$P(PSOCIBQ,"^")=1:1,1:"") Q
132 Q
133 ;
Note: See TracBrowser for help on using the repository browser.