source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPA.m@ 949

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

initial load of WorldVistAEHR
File size: 7.0 KB
Line 
1PSOCPA ;BHAM ISC/LGH - PHARMACY CO-PAY CANCEL & RESET STATUS OPTIONS ;05/27/92
2 ;;7.0;OUTPATIENT PHARMACY;**9,71,85,137,143,201**;DEC 1997
3 ;
4 ;REF/IA
5 ;^IBARX/125
6 ;^IBE(350.3/2216
7 ; PSO=1 (REMOVE CHARGE cancel),PSO=2 (UPDATE CHARGE called from EDIT)
8 ; PSO=3 (REMOVE CHARGE cancel in background processing) ... USED FOR PSOHLNE3
9 ;
10EN ;Entry point for Remove Co-Pay charge
11 S PSOFLAG=0
12 S PSO=1 ; Remove Co-Pay charge
13RX ;
14 G EXIT:PSO'>0
15 W ! S DIC="^PSRX(",DIC(0)="AEQMZ" D ^DIC K DIC G EXIT:Y<0 S PSODA=+Y
16RXED ; Entry point from PSORXED and PSORESK1...requires PSODA,PSO,PSODAYS,PSOFLAG
17 N POTBILL
18 S PSORXN=$P(^PSRX(PSODA,0),"^") ;..........Rx #
19 ; Determine if Rx is COPAY
20 I +$G(PSOPFS) S PSOREF=+$G(TYPE) G REASON
21 I PSO'=3 I '$D(^PSRX(PSODA,"IB")) W !,"Rx # ",PSORXN," is NOT a COPAY transaction...NO action taken." G EXIT
22 I PSO'=3 S PSOIB=^PSRX(PSODA,"IB")
23 I PSO=2!(PSO=1)!(PSO=3&($G(PSOREF)=0)) I $P(PSOIB,"^",2)'>0 S POTBILL=$P(PSOIB,"^",4) I POTBILL="",'$D(^PSRX(PSODA,1)) G EXIT ; No bill#, no refills
24 ;I PSO=3&($G(PSOREF)=0) I $P(PSOIB,"^",2)'>0 S POTBILL=$P(PSOIB,"^",4) I POTBILL="",'$D(^PSRX(PSODA,1)) G EXIT ; No bill#, no refills
25 ; Determine last entry in ^PSRX
26 I PSO=3&($D(^PSRX(PSODA,1))) G RXED2
27 S PSOREF=0
28 G:'$D(^PSRX(PSODA,1)) REASON
29 F PSZ=0:0 S PSZ=$O(^PSRX(PSODA,1,PSZ)) Q:PSZ'>0 S PSOREF=PSZ
30 S PSOIB=$G(^PSRX(PSODA,1,PSOREF,"IB"))
31RXED2 I PSO=2!(PSO=1)!(PSO=3) I $P(PSOIB,"^",1)'>0 S POTBILL=$P(PSOIB,"^",2)
32 G:($P(PSOIB,"^",1)'>0)&($G(POTBILL)'>0) EXIT ; No bill#
33REASON ;
34 N PSORD S:PSOREF>0 PSORD=$$GET1^DIQ(52.1,PSOREF_","_PSODA,"17","I") S:PSOREF=0 PSORD=$$GET1^DIQ(52,PSODA,"31","I")
35 ; Get Cancellation reason
36 I PSO=1!(PSO=3) G CANCEL2:$G(PSOPFS)&('$P(+$G(^PSRX(PSODA,"IB")),"^",1)) G PFS:$G(PSOPFS) G CANCEL
37 S DIC="^IBE(350.3,",DIC("S")="I $P(^(0),U,3)'=2",DIC(0)="AEQMZ",DIC("A")="Select CHARGE REMOVAL REASON : " D ^DIC S:$G(Y)<0 COPAYFLG=0 K DIC D ENDMSG:Y<0 G EXIT:Y<0 S PSORSN=+Y
38 I PSO=2&($G(PSOPFS))&($G(PSORD)) D Q:'$P(+$G(^PSRX(PSODA,"IB")),"^",1) D PFS2 G EXIT
39 . D CHRG^PSOPFSU1(PSODA,PSOREF,"CG",PSOPFS) ;only send charge msg if released
40 G UPDATE:PSO=2
41 G EXIT
42CANCEL ;
43 ; Set x=service^dfn^^user duz
44 ; x(n)=IB number^cancellation reason
45 N PSOIBST
46 ;G PFS:$G(PSOPFS)
47 I PSOREF=0,$P(PSOIB,"^",2)>0 S PSOIBST=$$STATUS^IBARX($P(PSOIB,"^",2)) I PSOIBST'=1,PSOIBST'=3 G EXITA
48 I $G(PSO)=1!(PSO=3) I PSOREF>0,$P(PSOIB,"^",1)>0 S PSOIBST=$$STATUS^IBARX($P(PSOIB,"^",1)) I PSOIBST'=1,PSOIBST'=3 G EXITA
49PFS I PSO'=3 S DIC="^IBE(350.3,",DIC("S")="I $P(^(0),U,3)'=2",DIC(0)="AEQMZ",DIC("A")="Select CHARGE REMOVAL REASON : " D ^DIC S:$G(Y)<0 COPAYFLG=0 K DIC D ENDMSG:Y<0 G EXIT:Y<0 S PSORSN=+Y
50 I PSO=3 S DIC="^IBE(350.3,",DIC(0)="QEZ",X="RX EDITED" D ^DIC K DIC G EXIT:Y<0 S PSORSN=+Y
51 G CANCEL2:$G(PSOPFS)
52 S X=PSOPAR7_"^"_+$P(^PSRX(PSODA,0),"^",2)_"^^"_DUZ
53 S:PSOREF=0 X(PSORXN)=$S($G(POTBILL)="":+$P(PSOIB,"^",2),1:POTBILL)_"^"_PSORSN ; Original Rx
54 S:PSOREF>0 X(PSORXN)=$S($G(POTBILL)="":+^PSRX(PSODA,1,PSOREF,"IB"),1:POTBILL)_"^"_PSORSN ; Refill Rx
55 I $G(POTBILL)'="" D CANIBAM^IBARX G CANCEL2
56 D CANCEL^IBARX
57 ; Return y=1 if success, -1^error code if error
58 ; y(n)=IB number^total charge^AR bill number
59 I +Y=-1 W !,"Error in processing...No action taken." G EXIT
60 G EXIT:'$D(Y(PSORXN))
61CANCEL2 I $G(PSOPFS)&($G(PSORD)) D CHRG^PSOPFSU1(PSODA,PSOREF,"CD",PSOPFS) ;only cancel charge if released
62 G EXIT:'($P(+$G(^PSRX(PSODA,"IB")),"^",1))
63 I $G(PSOPFS) D PFS2 G EXIT
64 D FILE
65 G EXIT
66FILE ;
67 ;G PFS2:$G(PSOPFS)
68 ; File new Bill # in ^PSRX
69 I '$G(POTBILL) S:PSOREF=0 $P(^PSRX(PSODA,"IB"),"^",2)=+Y(PSORXN) ;...Original Rx
70 I $G(POTBILL) S:PSOREF=0 $P(^PSRX(PSODA,"IB"),"^",4)="" ; IF POTENTIAL BILL IS CANCELLED, REMOVE ITS NUMBER FROM ^PSRX
71 I '$G(POTBILL) S:PSOREF>0 ^PSRX(PSODA,1,PSOREF,"IB")=+Y(PSORXN) ; ...Refill Rx
72 I $G(POTBILL) S:PSOREF>0 $P(^PSRX(PSODA,1,PSOREF,"IB"),"^",2)="" ; ...Refill Rx (REMOVE "POTENTIAL" BILL NUMBER WHEN CANCELLED)
73PFS2 ;
74 I PSO=1 W !!,"Co-Pay transaction for Rx # ",PSORXN,$S(PSOREF>0:" refill # "_PSOREF,1:"")," has been cancelled." S PREA="C",PSOCOMM="Returned to stock"
75 I PSO=2 W !!,"Co-Pay transaction for Rx # ",PSORXN,$S(PSOREF>0:" refill # "_PSOREF,1:"")," has been updated." S PREA="E",PSOCOMM="Days supply change. Copay amount updated"
76 D ACTLOG
77 Q
78UPDATE ;if days supply changes during Rx edit, cancel old bill and get new bill number
79 N SAVEDA
80 S SAVEDA=$G(DA)
81 I PSOFLAG=0 W !,"Use Pharmacy Manager Option - Edit Prescriptions - to UPDATE this Rx." G EXIT
82 ;
83 ; Set x=service^dfn^action type^user duz.....x value for update
84 ; x(n)=softlink^units^IB number of parent to cancel^Cancellation reason
85 ;
86 ;
87 S X=PSOPAR7_"^"_+$P(^PSRX(PSODA,0),"^",2)_"^"_$P(^PSRX(PSODA,"IB"),"^")_"^"_DUZ
88 ; Units for COPAY
89 S PSOCPUN=$P(($P(^PSRX(PSODA,0),"^",8)+29)/30,".",1)
90 G EXIT:PSOCPUN=$P((PSODAYS+29)/30,".",1) ; No change if UNITS unchanged
91 ;
92 ; Build softlink for x(n)
93 S X(PSORXN)="52:"_PSODA S:PSOREF>0 X(PSORXN)=X(PSORXN)_";1:"_PSOREF
94 ;
95 ; Set IB number of Parent record to update
96 S PSOPARNT=$S(PSOREF=0:+$P(^PSRX(PSODA,"IB"),"^",2),PSOREF>0:+^PSRX(PSODA,1,PSOREF,"IB"),1:0)
97 S X(PSORXN)=X(PSORXN)_"^"_PSOCPUN_"^"_PSOPARNT_"^"_PSORSN
98 I $G(POTBILL)'="" D
99 . S $P(X(PSORXN),"^",3)=POTBILL
100 . I $T(UPIBAM^IBARX)="" Q
101 . D UPIBAM^IBARX
102 I '$G(POTBILL) D UPDATE^IBARX
103 ; Return y=1 if success, -1^error code if error
104 ; y(n)=IB number^total charge^AR bill number
105 I +Y=-1 W !,"Error in processing...No action taken." G EXIT
106 G EXIT:'$D(Y(PSORXN))
107PFS3 ;
108 D FILE
109 G EXIT
110 ;
111RXDEL ; Entry point when Rx is deleted thru menu option -- THIS ENTRY POINT NO LONGER USED WITH MILL BILL COPAY CHANGES
112 K DIC S DIC="^IBE(350.3,",DIC(0)="M",X="RX DELETED" D ^DIC K DIC Q:+Y<0 S PSORSN=+Y
113 K Y
114 S PSODA=RXN,PSORXN=+RX
115 S X=PSOPAR7_"^"_+$P(RX,"^",2)_"^^"_DUZ
116 S X(PSORXN)=+$P(PSOIB,"^",2)_"^"_PSORSN ; Original Rx
117 D CANCEL^IBARX
118 W:+Y=1 !!,"Copay transaction for this Rx has been cancelled."
119 S PREA="C" D ACTLOG
120 G EXIT
121EXITA ;
122 I PSO=1 W !!,"Co-Pay transaction for Rx # ",PSORXN,$S(PSOREF>0:" refill # "_PSOREF,1:"")," has previously been cancelled."
123EXIT I $D(SAVEDA) S DA=SAVEDA ;
124 I PSO'=3 K PSO,PSOCPUN,PSODA,PSOFLAG,PSOIB,PSOPARNT,PSOREF,PSORSN,PSORXN,PSZ,X,Y Q
125 I PSO=3 K PSOCPUN,PSOPARNT,PSORXN,X,Y
126 Q
127ENDMSG ;
128 I PSO'=3 W !!,"Unable to UPDATE COPAY TRANSACTON without REMOVAL REASON entry."
129 Q
130ACTLOG ;ENTER MESSAGE INTO RX COPAY ACTIVITY LOG
131 Q:+$G(PSOPFS)&('$D(^PSRX(PSODA,"IB"))) ;don't set copay activity log when no copay when send Rx to external bill sys
132 N X,Y
133 S:'$D(PREA) PREA="R" D NOW^%DTC S PSI=0
134ACTL S PSI=+$O(^PSRX(PSODA,"COPAY",PSI)) G:$O(^PSRX(PSODA,"COPAY",PSI)) ACTL
135 K DIC,PSORSNZ I $G(PSORSN)'="" S DIC="^IBE(350.3,",DIC(0)="M",X="`"_PSORSN D ^DIC K DIC I $G(Y) S PSORSNZ=$P($G(Y),"^",2)
136 S PSORSNZ=$G(PSORSNZ)_$S($G(PSORSNZ)="":"",1:" ")_$G(PSOCOMM)
137 S ^PSRX(PSODA,"COPAY",+PSI+1,0)=%_"^"_PREA_"^"_DUZ_"^"_$G(PSOREF)_"^"_PSORSNZ_"^"_$G(PSOOLD)_"^"_$G(PSONW)
138 S ^PSRX(PSODA,"COPAY",0)="^52.0107DA^"_(+PSI+1)_"^"_(+PSI+1)
139 K PSORSNZ
140 Q
141 ;
Note: See TracBrowser for help on using the repository browser.