- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCP.m
r613 r623 1 PSOCP ;BIR/BAB - Pharmacy CO-PAY Application Utilities for IB ;02/06/92 2 ;;7.0;OUTPATIENT PHARMACY;**20,46,71,85,137,157,143,219,239,201,225**;DEC 1997;Build 29 3 ; 4 ;REF/IA - IBARX/125, SDCO22/1579, PS(55/2228, PSDRUG(/221, DGMSTAPI/2716, $$GETSHAD^DGUTL3/4462 5 CP ;Check if COPAY-Requires RXP,PSOSITE7 6 I '$D(PSOPAR) D ^PSOLSET G CP 7 K PSOCP 8 S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT 9 S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type 10 S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status 11 ; Set x=service^dfn^actiontype^user duz 12 I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^") 13 S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16) 14 ; 15 RX ;Determine Orig or Refill for RX 16 N PSOIB,PSOPFS S (PSOIB,PSOREF)=0 17 I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY 18 D PFSA^PSOPFSU1(RXP,PSOREF,2) G PFS:+PSOPFS 19 ; Check if bill exists 20 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I PSOIB G QUIT 21 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 G QUIT ; 'POTENTIAL BILL' - ALREADY ATTEMPTED TO BILL, BUT EXCEEDED ANNUAL COPAY CAP 22 I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1 I PSOIB G QUIT 23 I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT ; POTENTIAL BILL 24 PFS ; 25 S PSOCHG=1 ; set tem var to copay and check exception 26 N MAILMSG 27 D COPAYREL 28 I 'PSOCHG D D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) 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 D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) 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 PHARM, PROV, AND HOLDERS OF PSO COPAY KEY HOLDERS 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 ; 44 IBNEW ; Load ^TMP global for IB call 45 Q:$G(RXP)'>0 46 I PSOPFS D CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) 47 G QUIT:PSOPFS 48 N D0 49 G QUIT:'$D(X) 50 S XTMP=X,XTMP(1)=X(1) 51 ; 52 ; Requires x=service^dfn^action type^user duz 53 ; x(n)=softlink^units 54 I $P(X,"^",3)="" S $P(X,"^",3)=$P(^PSRX(RXP,"IB"),"^",1) 55 D NEW^IBARX 56 ; Returns y=1^total charges for this group or Y=-1^error code 57 ; y(n)=IB number^charge for this Rx^AR bill #^Cap met^Partial or Full charge^Copay Exempt^Number from file 354.71 58 ; Cap met ('1' - If patient has met cap amount or reached cap with this charge or '0' if not) 59 ; Partial or Full ('P' for partial billing, 'F' for full billing, null for no billing) 60 ; Copay Exempt - ('1' for exempt, '0' for non-exempt, '-1' for copay off (manila)), 61 ; ('1' - If patient has met cap amount or reach cap with this charge 62 ; Entry from file 354.71 will only be saved for fills that met the annual cap and could not be fully billed 63 ; 64 G QUIT:+Y=-1 65 S XTMP=XTMP_"^"_Y,XTMP(1)=XTMP(1)_"^"_Y(1) 66 ; 67 ; see if exempt or copay cap was met 68 I $P(Y(1),"^",6) D G QUIT 69 . S PREA="R",PSOOLD="Copay",PSONW="No Copay" 70 . S PSOCOMM="RX COPAY INCOME EXEMPTION" S PSODA=RXP D ACTLOG^PSOCPA 71 . S $P(^PSRX(RXP,"IB"),"^",1)="" 72 I $P(Y(1),"^",4) D 73 . 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") 74 . S PREA="A" 75 . S PSODA=RXP D ACTLOG^PSOCPA 76 . I $P(Y(1),"^",5)'="F" D 77 . . I PSOREF S $P(^PSRX(RXP,1,PSOREF,"IB"),"^",2)=$P(Y(1),"^",7) Q 78 . . S $P(^PSRX(RXP,"IB"),"^",4)=$P(Y(1),"^",7) 79 I $P(Y(1),"^",1)="" G QUIT 80 ; 81 FILE ;File IB number in ^PSRX 82 S PSOCP2=0 83 S PSOCP2=+$P(XTMP(1),":",3) 84 S:PSOCP2>0 ^PSRX(RXP,1,PSOCP2,"IB")=$P(XTMP(1),U,3) ; Filing in refill node 85 I PSOCP2>0,'$D(^PSRX(RXP,"IB")) S ^PSRX(RXP,"IB")="1^^" ; If refill "IB" exists, need "IB" entry on original fill node 86 S:PSOCP2=0 $P(^PSRX(RXP,"IB"),"^",2)=$P(XTMP(1),U,3) ;Filing in original fill (zero node) 87 QUIT ; 88 K Y,PSOCP1,PSOCP2,QQ,PSOCPN,X,X2,XTMP,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PSOCOMM,PSOOLD,PSONW,PREA,PSORSN 89 Q 90 EN D ^PSOLSET 91 EN1 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 92 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^") 93 S PSODFN=$P(^PSRX(RXP,0),"^",2) 94 D CP G EN1 95 EXIT K RXP D FINAL^PSOLSET Q 96 ; 97 SC(PSODFN,PSODD) ;sup ref for CPRS, Pre-Copay enhancement 98 N PSOSC 99 I $$DT^PSOMLLDT S PSOSC="" G SCQ 100 I $G(PSODD),($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") S PSOSC=1 G SCQ 101 I $P($G(^PS(55,+$G(PSODFN),"PS")),"^"),$P($G(^PS(53,+$P(^("PS"),"^"),0)),"^",7) S PSOSC=1 G SCQ 102 N I,J,X S (X,PSOSC)="" 103 S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q 104 G:'X SCQ 105 S X=X_"^"_PSODFN D XTYPE^IBARX 106 S J="" F S J=$O(Y(J)) Q:'J S I="" F S I=$O(Y(J,I)) Q:I="" S:I>0 PSOSC=I 107 SCQ Q $S($G(PSOSC)=2:0,1:1) 108 ; 109 COPAYREL ; Recheck copay status at release 110 ; check Rx patient status 111 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 112 ; see if drug is investigational or supply 113 N DRG,DRGTYP,X 114 S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3) 115 I DRGTYP["I" S PSOCOMM="Investigational Drug",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0 116 I DRGTYP["S" S PSOCOMM="Supply Item",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0 117 K PSOTG,CHKXTYPE 118 I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1 119 I $G(^PSRX(RXP,"IBQ"))["1" D S PSOCHG=0,PSOOLD="Copay",PSONW="No Copay" Q ; COPAY EXEMPT 120 . N EXMT,II,PSOCIBQ 121 . S PSOCIBQ=$G(^PSRX(RXP,"IBQ")) 122 . F II=1,7,3,4,5,6,2,8 I $P(PSOCIBQ,"^",II)=1 S EXMT=$S(II=1:"SC",II=7:"CV",II=3:"AO",II=4:"IR",II=5:"EC",II=8:"SHAD",II=2:"MST",II=6:"HNC",1:"") D:EXMT'="" SETCOMM Q 123 D SCNEW(.PSOTG,PSOCPN,DRG,RXP) 124 N EXMT 125 I '$D(CHKXTYPE) D XTYPE 126 F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $D(PSOTG(EXMT)) D I 'PSOCHG Q 127 . I PSOTG(EXMT)=1 S PSOCHG=0 D SETCOMM 128 I 'PSOCHG S PSOOLD="Copay",PSONW="No Copay" Q 129 ; 130 ; If any of the applicable exemption quest have never been answered, send a mail msg with all of the quest 131 S EXMT="",MAILMSG=0 F S EXMT=$O(PSOTG(EXMT)) Q:EXMT="" I PSOTG(EXMT)="" S MAILMSG=1 Q 132 I MAILMSG,$D(PSOTG("SC")) I $G(PSOTG("SC"))="" S PSOCHG=2 ; 'SC' quest not answered, don't reset copay status to 'copay' 133 Q 134 ; 135 SCNEW(PSOTG,PSOPT,PSODR,PSORN) ;CPRS supported ref 136 I '$$DT^PSOMLLDT Q 137 I '$G(PSOPT) Q 138 ;I $G(PSODR),($P($G(^PSDRUG(PSODR,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") Q ;CIDC ALWAYS ASK 139 N PSOCIBQ,PSOQMSH,PSOQVEH,PSOQRQD,PSOQHNC,PSOQPGW,DFN,PSOSCA,ZXX 140 K PSOANSQ("SC>50") 141 S DFN=PSOPT 142 D SCP^PSORN52D S:PSOSCP>49&(PSOSCA) PSOANSQ("SC>50")=1 143 I $G(PSORN) D 144 . S PSOCIBQ=$G(^PSRX(PSORN,"IBQ")) 145 . I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(PSORN,"ICD",1,0)) D ICD:ZXX'="" 146 I '$G(PSORN) S PSOCIBQ="" 147 ;Rx Patient Status check is not being done here 148 N PSOSCMX,Y,I,J,X S (X,PSOSCMX)="" 149 S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q 150 G:'X SKIP 151 S X=X_"^"_PSOPT D XTYPE^IBARX 152 S J="" F S J=$O(Y(J)) Q:'J S I="" F S I=$O(Y(J,I)) Q:I="" S:I>0 PSOSCMX=I 153 SKIP ; 154 I $G(PSOSCA)!($G(PSOSCMX)=2) S PSOTG("SC")=$S($P(PSOCIBQ,"^")=1:1,$P(PSOCIBQ,"^")=0:0,$G(PSORN)&($P($G(^PSRX(+$G(PSORN),"IB")),"^")):0,1:"") 155 S:$$AO^SDCO22(PSOPT) PSOTG("AO")=$S($P(PSOCIBQ,"^",3)=1:1,$P(PSOCIBQ,"^",3)=0:0,1:"") 156 S:$$IR^SDCO22(PSOPT) PSOTG("IR")=$S($P(PSOCIBQ,"^",4)=1:1,$P(PSOCIBQ,"^",4)=0:0,1:"") 157 S:$$EC^SDCO22(PSOPT) PSOTG("EC")=$S($P(PSOCIBQ,"^",5)=1:1,$P(PSOCIBQ,"^",5)=0:0,1:"") 158 S:$P($$GETSTAT^DGMSTAPI(PSOPT),"^",2)="Y" PSOTG("MST")=$S($P(PSOCIBQ,"^",2)=1:1,$P(PSOCIBQ,"^",2)=0:0,1:"") 159 I $T(GETCUR^DGNTAPI)]"" N PSONC,PSONCX S PSONCX=$$GETCUR^DGNTAPI(PSOPT,"PSONC") I $P($G(PSONC("IND")),"^")="Y" S PSOTG("HNC")=$S($P(PSOCIBQ,"^",6)=1:1,$P(PSOCIBQ,"^",6)=0:0,1:"") 160 S:$P($$CVEDT^DGCV(PSOPT),"^",3) PSOTG("CV")=$S($P(PSOCIBQ,"^",7)=1:1,$P(PSOCIBQ,"^",7)=0:0,1:"") 161 I $L($T(GETSHAD^DGUTL3)) S:$$GETSHAD^DGUTL3(PSOPT)=1 PSOTG("SHAD")=$S($P(PSOCIBQ,"^",8)=1:1,$P(PSOCIBQ,"^",8)=0:0,1:"") 162 Q 163 ; 164 ICD ; 165 D ICD^PSOCP1 166 Q 167 XTYPE ; 168 N PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY,ZXX 169 S (X,PSOSCMX,SAVY)="" 170 S PSOCIBQ=$G(^PSRX(RXP,"IBQ")) I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(RXP,"ICD",1,0)) D ICD:ZXX'="" 171 I $P(PSOCIBQ,"^",1)'="" S PSOTG("SC")=$P(PSOCIBQ,"^",1) 172 I $D(PSOTG("SC")),$P(PSOCIBQ,"^",1)="" S PSOTG("SC")="" ; USE "CURRENT" SETTING AS ANS TO SC QUEST IF IT APPLIES 173 S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q 174 I 'X Q 175 S X=X_"^"_PSOCPN D XTYPE^IBARX 176 I $G(Y)'=1 Q 177 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 178 I PSOSCMX="",SAVY=0 S PSOCHG=0 S PSOCOMM="Exempt from copayment" Q ; INCOME EXEMPT OR SC 179 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 180 Q 181 ; 182 SETCOMM ; 183 D SETCOMM^PSOCP1 184 Q 185 ; 1 PSOCP ;BIR/BAB - Pharmacy CO-PAY Application Utilities for IB ;02/06/92 2 ;;7.0;OUTPATIENT PHARMACY;**20,46,71,85,137,157,143,219,239,201**;DEC 1997 3 ; 4 ;REF/IA - IBARX/125, SDCO22/1579, PS(55/2228, PSDRUG(/221, DGMSTAPI/2716 5 CP ;Check if COPAY-Requires RXP,PSOSITE7 6 I '$D(PSOPAR) D ^PSOLSET G CP 7 K PSOCP 8 S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT 9 S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type 10 S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status 11 ; Set x=service^dfn^actiontype^user duz 12 I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^") 13 S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16) 14 ; 15 RX ;Determine Orig or Refill for RX 16 N PSOIB,PSOPFS S (PSOIB,PSOREF)=0 17 I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY 18 D PFSA^PSOPFSU1(RXP,PSOREF,2) G PFS:+PSOPFS 19 ; Check if bill exists 20 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I PSOIB G QUIT 21 I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 G QUIT ; 'POTENTIAL BILL' - ALREADY ATTEMPTED TO BILL, BUT EXCEEDED ANNUAL COPAY CAP 22 I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1 I PSOIB G QUIT 23 I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT ; POTENTIAL BILL 24 PFS ; 25 S PSOCHG=1 ; set tem var to copay and check exception 26 N MAILMSG 27 D COPAYREL 28 I 'PSOCHG D D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) 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 D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) 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 PHARM, PROV, AND HOLDERS OF PSO COPAY KEY HOLDERS 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 ; 44 IBNEW ; Load ^TMP global for IB call 45 Q:$G(RXP)'>0 46 I PSOPFS D CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) 47 G QUIT:PSOPFS 48 N D0 49 G QUIT:'$D(X) 50 S XTMP=X,XTMP(1)=X(1) 51 ; 52 ; Requires x=service^dfn^action type^user duz 53 ; x(n)=softlink^units 54 I $P(X,"^",3)="" S $P(X,"^",3)=$P(^PSRX(RXP,"IB"),"^",1) 55 D NEW^IBARX 56 ; Returns y=1^total charges for this group or Y=-1^error code 57 ; y(n)=IB number^charge for this Rx^AR bill #^Cap met^Partial or Full charge^Copay Exempt^Number from file 354.71 58 ; Cap met ('1' - If patient has met cap amount or reached cap with this charge or '0' if not) 59 ; Partial or Full ('P' for partial billing, 'F' for full billing, null for no billing) 60 ; Copay Exempt - ('1' for exempt, '0' for non-exempt, '-1' for copay off (manila)), 61 ; ('1' - If patient has met cap amount or reach cap with this charge 62 ; Entry from file 354.71 will only be saved for fills that met the annual cap and could not be fully billed 63 ; 64 G QUIT:+Y=-1 65 S XTMP=XTMP_"^"_Y,XTMP(1)=XTMP(1)_"^"_Y(1) 66 ; 67 ; see if exempt or copay cap was met 68 I $P(Y(1),"^",6) D G QUIT 69 . S PREA="R",PSOOLD="Copay",PSONW="No Copay" 70 . S PSOCOMM="RX COPAY INCOME EXEMPTION" S PSODA=RXP D ACTLOG^PSOCPA 71 . S $P(^PSRX(RXP,"IB"),"^",1)="" 72 I $P(Y(1),"^",4) D 73 . 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") 74 . S PREA="A" 75 . S PSODA=RXP D ACTLOG^PSOCPA 76 . I $P(Y(1),"^",5)'="F" D 77 . . I PSOREF S $P(^PSRX(RXP,1,PSOREF,"IB"),"^",2)=$P(Y(1),"^",7) Q 78 . . S $P(^PSRX(RXP,"IB"),"^",4)=$P(Y(1),"^",7) 79 I $P(Y(1),"^",1)="" G QUIT 80 ; 81 FILE ;File IB number in ^PSRX 82 S PSOCP2=0 83 S PSOCP2=+$P(XTMP(1),":",3) 84 S:PSOCP2>0 ^PSRX(RXP,1,PSOCP2,"IB")=$P(XTMP(1),U,3) ; Filing in refill node 85 I PSOCP2>0,'$D(^PSRX(RXP,"IB")) S ^PSRX(RXP,"IB")="1^^" ; If refill "IB" exists, need "IB" entry on original fill node 86 S:PSOCP2=0 $P(^PSRX(RXP,"IB"),"^",2)=$P(XTMP(1),U,3) ;Filing in original fill (zero node) 87 QUIT ; 88 K Y,PSOCP1,PSOCP2,QQ,PSOCPN,X,X2,XTMP,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PSOCOMM,PSOOLD,PSONW,PREA,PSORSN 89 Q 90 EN D ^PSOLSET 91 EN1 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 92 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^") 93 S PSODFN=$P(^PSRX(RXP,0),"^",2) 94 D CP G EN1 95 EXIT K RXP D FINAL^PSOLSET Q 96 ; 97 SC(PSODFN,PSODD) ;sup ref for CPRS, Pre-Copay enhancement 98 N PSOSC 99 I $$DT^PSOMLLDT S PSOSC="" G SCQ 100 I $G(PSODD),($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") S PSOSC=1 G SCQ 101 I $P($G(^PS(55,+$G(PSODFN),"PS")),"^"),$P($G(^PS(53,+$P(^("PS"),"^"),0)),"^",7) S PSOSC=1 G SCQ 102 N I,J,X S (X,PSOSC)="" 103 S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q 104 G:'X SCQ 105 S X=X_"^"_PSODFN D XTYPE^IBARX 106 S J="" F S J=$O(Y(J)) Q:'J S I="" F S I=$O(Y(J,I)) Q:I="" S:I>0 PSOSC=I 107 SCQ Q $S($G(PSOSC)=2:0,1:1) 108 ; 109 COPAYREL ; Recheck copay status at release 110 ; check Rx patient status 111 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 112 ; see if drug is investigational or supply 113 N DRG,DRGTYP,X 114 S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3) 115 I DRGTYP["I" S PSOCOMM="Investigational Drug",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0 116 I DRGTYP["S" S PSOCOMM="Supply Item",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0 117 K PSOTG,CHKXTYPE 118 I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1 119 I $G(^PSRX(RXP,"IBQ"))["1" D S PSOCHG=0,PSOOLD="Copay",PSONW="No Copay" Q ; COPAY EXEMPT 120 . N EXMT,II,PSOCIBQ 121 . S PSOCIBQ=$G(^PSRX(RXP,"IBQ")) 122 . F II=1,7,3,4,5,6,2 I $P(PSOCIBQ,"^",II)=1 S EXMT=$S(II=1:"SC",II=7:"CV",II=3:"AO",II=4:"IR",II=5:"EC",II=2:"MST",II=6:"HNC",1:"") D:EXMT'="" SETCOMM Q 123 D SCNEW(.PSOTG,PSOCPN,DRG,RXP) 124 N EXMT 125 I '$D(CHKXTYPE) D XTYPE 126 F EXMT="SC","CV","AO","IR","EC","MST","HNC" I $D(PSOTG(EXMT)) D I 'PSOCHG Q 127 . I PSOTG(EXMT)=1 S PSOCHG=0 D SETCOMM 128 I 'PSOCHG S PSOOLD="Copay",PSONW="No Copay" Q 129 ; 130 ; If any of the applicable exemption quest have never been answered, send a mail msg with all of the quest 131 S EXMT="",MAILMSG=0 F S EXMT=$O(PSOTG(EXMT)) Q:EXMT="" I PSOTG(EXMT)="" S MAILMSG=1 Q 132 I MAILMSG,$D(PSOTG("SC")) I $G(PSOTG("SC"))="" S PSOCHG=2 ; 'SC' quest not answered, don't reset copay status to 'copay' 133 Q 134 ; 135 SCNEW(PSOTG,PSOPT,PSODR,PSORN) ;CPRS supported ref 136 I '$$DT^PSOMLLDT Q 137 I '$G(PSOPT) Q 138 ;I $G(PSODR),($P($G(^PSDRUG(PSODR,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") Q ;CIDC ALWAYS ASK 139 N PSOCIBQ,PSOQMSH,PSOQVEH,PSOQRQD,PSOQHNC,PSOQPGW,DFN,PSOSCA,ZXX 140 K PSOANSQ("SC>50") 141 S DFN=PSOPT 142 D SCP^PSORN52D S:PSOSCP>49&(PSOSCA) PSOANSQ("SC>50")=1 143 I $G(PSORN) D 144 . S PSOCIBQ=$G(^PSRX(PSORN,"IBQ")) 145 . I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(PSORN,"ICD",1,0)) D ICD:ZXX'="" 146 I '$G(PSORN) S PSOCIBQ="" 147 ;Rx Patient Status check is not being done here 148 N PSOSCMX,Y,I,J,X S (X,PSOSCMX)="" 149 S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q 150 G:'X SKIP 151 S X=X_"^"_PSOPT D XTYPE^IBARX 152 S J="" F S J=$O(Y(J)) Q:'J S I="" F S I=$O(Y(J,I)) Q:I="" S:I>0 PSOSCMX=I 153 SKIP ; 154 I $G(PSOSCA)!($G(PSOSCMX)=2) S PSOTG("SC")=$S($P(PSOCIBQ,"^")=1:1,$P(PSOCIBQ,"^")=0:0,$G(PSORN)&($P($G(^PSRX(+$G(PSORN),"IB")),"^")):0,1:"") 155 S:$$AO^SDCO22(PSOPT) PSOTG("AO")=$S($P(PSOCIBQ,"^",3)=1:1,$P(PSOCIBQ,"^",3)=0:0,1:"") 156 S:$$IR^SDCO22(PSOPT) PSOTG("IR")=$S($P(PSOCIBQ,"^",4)=1:1,$P(PSOCIBQ,"^",4)=0:0,1:"") 157 S:$$EC^SDCO22(PSOPT) PSOTG("EC")=$S($P(PSOCIBQ,"^",5)=1:1,$P(PSOCIBQ,"^",5)=0:0,1:"") 158 S:$P($$GETSTAT^DGMSTAPI(PSOPT),"^",2)="Y" PSOTG("MST")=$S($P(PSOCIBQ,"^",2)=1:1,$P(PSOCIBQ,"^",2)=0:0,1:"") 159 I $T(GETCUR^DGNTAPI)]"" N PSONC,PSONCX S PSONCX=$$GETCUR^DGNTAPI(PSOPT,"PSONC") I $P($G(PSONC("IND")),"^")="Y" S PSOTG("HNC")=$S($P(PSOCIBQ,"^",6)=1:1,$P(PSOCIBQ,"^",6)=0:0,1:"") 160 S:$P($$CVEDT^DGCV(PSOPT),"^",3) PSOTG("CV")=$S($P(PSOCIBQ,"^",7)=1:1,$P(PSOCIBQ,"^",7)=0:0,1:"") 161 Q 162 ; 163 ICD ; 164 D ICD^PSOCP1 165 Q 166 XTYPE ; 167 N PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY,ZXX 168 S (X,PSOSCMX,SAVY)="" 169 S PSOCIBQ=$G(^PSRX(RXP,"IBQ")) I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(RXP,"ICD",1,0)) D ICD:ZXX'="" 170 I $P(PSOCIBQ,"^",1)'="" S PSOTG("SC")=$P(PSOCIBQ,"^",1) 171 I $D(PSOTG("SC")),$P(PSOCIBQ,"^",1)="" S PSOTG("SC")="" ; USE "CURRENT" SETTING AS ANS TO SC QUEST IF IT APPLIES 172 S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q 173 I 'X Q 174 S X=X_"^"_PSOCPN D XTYPE^IBARX 175 I $G(Y)'=1 Q 176 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 177 I PSOSCMX="",SAVY=0 S PSOCHG=0 S PSOCOMM="Exempt from copayment" Q ; INCOME EXEMPT OR SC 178 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 179 Q 180 ; 181 SETCOMM ; 182 D SETCOMM^PSOCP1 183 Q 184 ;
Note:
See TracChangeset
for help on using the changeset viewer.
