PSOCPA ;BHAM ISC/LGH - PHARMACY CO-PAY CANCEL & RESET STATUS OPTIONS ;05/27/92
;;7.0;OUTPATIENT PHARMACY;**9,71,85,137,143,201,681**;DEC 1997;Build 11
;
; Reference to (multiple)^IBARX in ICR #125
; Reference to ^IBE(350.3 in ICR #2216
;
; PSO=1 (REMOVE CHARGE cancel)
; PSO=2 (UPDATE CHARGE called from EDIT)
; PSO=3 (REMOVE CHARGE cancel in background processing) ... USED FOR PSOHLNE3
;
EN ;Entry point for Remove Co-Pay charge
S PSOFLAG=0
S PSO=1 ; Remove Co-Pay charge
RX ;
G EXIT:PSO'>0
W ! S DIC="^PSRX(",DIC(0)="AEQMZ" D ^DIC K DIC G EXIT:Y<0 S PSODA=+Y
RXED ; Entry point from PSORXED and PSORESK1...requires PSODA,PSO,PSODAYS,PSOFLAG
N POTBILL
S PSORXN=$P(^PSRX(PSODA,0),"^") ;..........Rx #
; Determine if Rx is COPAY
I +$G(PSOPFS) S PSOREF=+$G(TYPE) G REASON
I PSO'=3 I '$D(^PSRX(PSODA,"IB")) W !,"Rx # ",PSORXN," is NOT a COPAY transaction...NO action taken." G EXIT
I PSO'=3 S PSOIB=^PSRX(PSODA,"IB")
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
;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
; Determine last entry in ^PSRX
I PSO=3&($D(^PSRX(PSODA,1))) G RXED2
S PSOREF=0
G:'$D(^PSRX(PSODA,1)) REASON
F PSZ=0:0 S PSZ=$O(^PSRX(PSODA,1,PSZ)) Q:PSZ'>0 S PSOREF=PSZ
S PSOIB=$G(^PSRX(PSODA,1,PSOREF,"IB"))
RXED2 I PSO=2!(PSO=1)!(PSO=3) I $P(PSOIB,"^",1)'>0 S POTBILL=$P(PSOIB,"^",2)
G:($P(PSOIB,"^",1)'>0)&($G(POTBILL)'>0) EXIT ; No bill#
REASON ;
N PSORD S:PSOREF>0 PSORD=$$GET1^DIQ(52.1,PSOREF_","_PSODA,"17","I") S:PSOREF=0 PSORD=$$GET1^DIQ(52,PSODA,"31","I")
; Get Cancellation reason
I PSO=1!(PSO=3) G CANCEL2:$G(PSOPFS)&('$P(+$G(^PSRX(PSODA,"IB")),"^",1)) G PFS:$G(PSOPFS) G CANCEL
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
I PSO=2&($G(PSOPFS))&($G(PSORD)) D Q:'$P(+$G(^PSRX(PSODA,"IB")),"^",1) D PFS2 G EXIT
. D CHRG^PSOPFSU1(PSODA,PSOREF,"CG",PSOPFS) ;only send charge msg if released
G UPDATE:PSO=2
G EXIT
;
CANCEL ;
; Set x=service^dfn^^user duz
; x(n)=IB number^cancellation reason
N PSOIBST
;G PFS:$G(PSOPFS)
I PSOREF=0,$P(PSOIB,"^",2)>0 S PSOIBST=$$STATUS^IBARX($P(PSOIB,"^",2)) I PSOIBST'=1,PSOIBST'=3 G EXITA
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
PFS 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
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
G CANCEL2:$G(PSOPFS)
S X=PSOPAR7_"^"_+$P(^PSRX(PSODA,0),"^",2)_"^^"_DUZ
S:PSOREF=0 X(PSORXN)=$S($G(POTBILL)="":+$P(PSOIB,"^",2),1:POTBILL)_"^"_PSORSN ; Original Rx
S:PSOREF>0 X(PSORXN)=$S($G(POTBILL)="":+^PSRX(PSODA,1,PSOREF,"IB"),1:POTBILL)_"^"_PSORSN ; Refill Rx
I $G(POTBILL)'="" D CANIBAM^IBARX G CANCEL2
D CANCEL^IBARX
; Return y=1 if success, -1^error code if error
; y(n)=IB number^total charge^AR bill number
I +Y=-1 W !,"Error in processing...No action taken." G EXIT
G EXIT:'$D(Y(PSORXN))
CANCEL2 I $G(PSOPFS)&($G(PSORD)) D CHRG^PSOPFSU1(PSODA,PSOREF,"CD",PSOPFS) ;only cancel charge if released
G EXIT:'($P(+$G(^PSRX(PSODA,"IB")),"^",1))
I $G(PSOPFS) D PFS2 G EXIT
D FILE
G EXIT
;
FILE ;
;G PFS2:$G(PSOPFS)
; File new Bill # in ^PSRX
I '$G(POTBILL) S:PSOREF=0 $P(^PSRX(PSODA,"IB"),"^",2)=+Y(PSORXN) ;...Original Rx
I $G(POTBILL) S:PSOREF=0 $P(^PSRX(PSODA,"IB"),"^",4)="" ; IF POTENTIAL BILL IS CANCELLED, REMOVE ITS NUMBER FROM ^PSRX
I '$G(POTBILL) S:PSOREF>0 ^PSRX(PSODA,1,PSOREF,"IB")=+Y(PSORXN) ; ...Refill Rx
I $G(POTBILL) S:PSOREF>0 $P(^PSRX(PSODA,1,PSOREF,"IB"),"^",2)="" ; ...Refill Rx (REMOVE "POTENTIAL" BILL NUMBER WHEN CANCELLED)
PFS2 ;
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"
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"
D ACTLOG
Q
;
UPDATE ;if days supply changes during Rx edit, cancel old bill and get new bill number
N SAVEDA
S SAVEDA=$G(DA)
I PSOFLAG=0 W !,"Use Pharmacy Manager Option - Edit Prescriptions - to UPDATE this Rx." G EXIT
;
; Set x=service^dfn^action type^user duz.....x value for update
; x(n)=softlink^units^IB number of parent to cancel^Cancellation reason
;
;
S X=PSOPAR7_"^"_+$P(^PSRX(PSODA,0),"^",2)_"^"_$P(^PSRX(PSODA,"IB"),"^")_"^"_DUZ
; Units for COPAY
S PSOCPUN=$P(($P(^PSRX(PSODA,0),"^",8)+29)/30,".",1)
G EXIT:PSOCPUN=$P((PSODAYS+29)/30,".",1) ; No change if UNITS unchanged
;
; Build softlink for x(n)
S X(PSORXN)="52:"_PSODA S:PSOREF>0 X(PSORXN)=X(PSORXN)_";1:"_PSOREF
;
; Set IB number of Parent record to update
S PSOPARNT=$S(PSOREF=0:+$P(^PSRX(PSODA,"IB"),"^",2),PSOREF>0:+^PSRX(PSODA,1,PSOREF,"IB"),1:0)
S X(PSORXN)=X(PSORXN)_"^"_PSOCPUN_"^"_PSOPARNT_"^"_PSORSN
I $G(POTBILL)'="" D
. S $P(X(PSORXN),"^",3)=POTBILL
. I $T(UPIBAM^IBARX)="" Q
. D UPIBAM^IBARX
I '$G(POTBILL) D UPDATE^IBARX
; Return y=1 if success, -1^error code if error
; y(n)=IB number^total charge^AR bill number
I +Y=-1 W !,"Error in processing...No action taken." G EXIT
G EXIT:'$D(Y(PSORXN))
PFS3 ;
D FILE
G EXIT
;
RXDEL ; Entry point when Rx is deleted thru menu option -- THIS ENTRY POINT NO LONGER USED WITH MILL BILL COPAY CHANGES
K DIC S DIC="^IBE(350.3,",DIC(0)="M",X="RX DELETED" D ^DIC K DIC Q:+Y<0 S PSORSN=+Y
K Y
S PSODA=RXN,PSORXN=+RX
S X=PSOPAR7_"^"_+$P(RX,"^",2)_"^^"_DUZ
S X(PSORXN)=+$P(PSOIB,"^",2)_"^"_PSORSN ; Original Rx
D CANCEL^IBARX
W:+Y=1 !!,"Copay transaction for this Rx has been cancelled."
S PREA="C" D ACTLOG
G EXIT
;
EXITA ;
I PSO=1 W !!,"Co-Pay transaction for Rx # ",PSORXN,$S(PSOREF>0:" refill # "_PSOREF,1:"")," has previously been cancelled."
EXIT I $D(SAVEDA) S DA=SAVEDA ;
I PSO'=3 K PSO,PSOCPUN,PSODA,PSOFLAG,PSOIB,PSOPARNT,PSOREF,PSORSN,PSORXN,PSZ,X,Y Q
I PSO=3 K PSOCPUN,PSOPARNT,PSORXN,X,Y
Q
;
ENDMSG ;
I PSO'=3 W !!,"Unable to UPDATE COPAY TRANSACTON without REMOVAL REASON entry."
Q
;
ACTLOG ;ENTER MESSAGE INTO RX COPAY ACTIVITY LOG
I +$G(PSOPFS)&('$D(^PSRX(PSODA,"IB"))) Q ;don't set copay activity log when no copay when send Rx to external bill sys
N PSODUZ,X,Y
S PSODUZ=DUZ
I '$D(^VA(200,+PSODUZ,0)) S PSODUZ=.5
I '$D(PREA) S PREA="R"
D NOW^%DTC
S PSI=0
ACTL ;
S PSI=+$O(^PSRX(PSODA,"COPAY",PSI))
I $O(^PSRX(PSODA,"COPAY",PSI)) G ACTL
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)
S PSORSNZ=$G(PSORSNZ)_$S($G(PSORSNZ)="":"",1:" ")_$G(PSOCOMM)
S ^PSRX(PSODA,"COPAY",+PSI+1,0)=%_"^"_PREA_"^"_PSODUZ_"^"_$G(PSOREF)_"^"_PSORSNZ_"^"_$G(PSOOLD)_"^"_$G(PSONW)
S ^PSRX(PSODA,"COPAY",0)="^52.0107DA^"_(+PSI+1)_"^"_(+PSI+1)
K PSORSNZ
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPA 7447 printed Apr 09, 2024@21:27:30 Page 2
PSOCPA ;BHAM ISC/LGH - PHARMACY CO-PAY CANCEL & RESET STATUS OPTIONS ;05/27/92
+1 ;;7.0;OUTPATIENT PHARMACY;**9,71,85,137,143,201,681**;DEC 1997;Build 11
+2 ;
+3 ; Reference to (multiple)^IBARX in ICR #125
+4 ; Reference to ^IBE(350.3 in ICR #2216
+5 ;
+6 ; PSO=1 (REMOVE CHARGE cancel)
+7 ; PSO=2 (UPDATE CHARGE called from EDIT)
+8 ; PSO=3 (REMOVE CHARGE cancel in background processing) ... USED FOR PSOHLNE3
+9 ;
EN ;Entry point for Remove Co-Pay charge
+1 SET PSOFLAG=0
+2 ; Remove Co-Pay charge
SET PSO=1
RX ;
+1 if PSO'>0
GOTO EXIT
+2 WRITE !
SET DIC="^PSRX("
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
if Y<0
GOTO EXIT
SET PSODA=+Y
RXED ; Entry point from PSORXED and PSORESK1...requires PSODA,PSO,PSODAYS,PSOFLAG
+1 NEW POTBILL
+2 ;..........Rx #
SET PSORXN=$PIECE(^PSRX(PSODA,0),"^")
+3 ; Determine if Rx is COPAY
+4 IF +$GET(PSOPFS)
SET PSOREF=+$GET(TYPE)
GOTO REASON
+5 IF PSO'=3
IF '$DATA(^PSRX(PSODA,"IB"))
WRITE !,"Rx # ",PSORXN," is NOT a COPAY transaction...NO action taken."
GOTO EXIT
+6 IF PSO'=3
SET PSOIB=^PSRX(PSODA,"IB")
+7 ; No bill#, no refills
IF PSO=2!(PSO=1)!(PSO=3&($GET(PSOREF)=0))
IF $PIECE(PSOIB,"^",2)'>0
SET POTBILL=$PIECE(PSOIB,"^",4)
IF POTBILL=""
IF '$DATA(^PSRX(PSODA,1))
GOTO EXIT
+8 ;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
+9 ; Determine last entry in ^PSRX
+10 IF PSO=3&($DATA(^PSRX(PSODA,1)))
GOTO RXED2
+11 SET PSOREF=0
+12 if '$DATA(^PSRX(PSODA,1))
GOTO REASON
+13 FOR PSZ=0:0
SET PSZ=$ORDER(^PSRX(PSODA,1,PSZ))
if PSZ'>0
QUIT
SET PSOREF=PSZ
+14 SET PSOIB=$GET(^PSRX(PSODA,1,PSOREF,"IB"))
RXED2 IF PSO=2!(PSO=1)!(PSO=3)
IF $PIECE(PSOIB,"^",1)'>0
SET POTBILL=$PIECE(PSOIB,"^",2)
+1 ; No bill#
if ($PIECE(PSOIB,"^",1)'>0)&($GET(POTBILL)'>0)
GOTO EXIT
REASON ;
+1 NEW PSORD
if PSOREF>0
SET PSORD=$$GET1^DIQ(52.1,PSOREF_","_PSODA,"17","I")
if PSOREF=0
SET PSORD=$$GET1^DIQ(52,PSODA,"31","I")
+2 ; Get Cancellation reason
+3 IF PSO=1!(PSO=3)
if $GET(PSOPFS)&('$PIECE(+$GET(^PSRX(PSODA,"IB")),"^",1))
GOTO CANCEL2
if $GET(PSOPFS)
GOTO PFS
GOTO CANCEL
+4 SET DIC="^IBE(350.3,"
SET DIC("S")="I $P(^(0),U,3)'=2"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select CHARGE REMOVAL REASON : "
DO ^DIC
if $GET(Y)<0
SET COPAYFLG=0
KILL DIC
if Y<0
DO ENDMSG
if Y<0
GOTO EXIT
SET PSORSN=+Y
+5 IF PSO=2&($GET(PSOPFS))&($GET(PSORD))
Begin DoDot:1
+6 ;only send charge msg if released
DO CHRG^PSOPFSU1(PSODA,PSOREF,"CG",PSOPFS)
End DoDot:1
if '$PIECE(+$GET(^PSRX(PSODA,"IB")),"^",1)
QUIT
DO PFS2
GOTO EXIT
+7 if PSO=2
GOTO UPDATE
+8 GOTO EXIT
+9 ;
CANCEL ;
+1 ; Set x=service^dfn^^user duz
+2 ; x(n)=IB number^cancellation reason
+3 NEW PSOIBST
+4 ;G PFS:$G(PSOPFS)
+5 IF PSOREF=0
IF $PIECE(PSOIB,"^",2)>0
SET PSOIBST=$$STATUS^IBARX($PIECE(PSOIB,"^",2))
IF PSOIBST'=1
IF PSOIBST'=3
GOTO EXITA
+6 IF $GET(PSO)=1!(PSO=3)
IF PSOREF>0
IF $PIECE(PSOIB,"^",1)>0
SET PSOIBST=$$STATUS^IBARX($PIECE(PSOIB,"^",1))
IF PSOIBST'=1
IF PSOIBST'=3
GOTO EXITA
PFS IF PSO'=3
SET DIC="^IBE(350.3,"
SET DIC("S")="I $P(^(0),U,3)'=2"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select CHARGE REMOVAL REASON : "
DO ^DIC
if $GET(Y)<0
SET COPAYFLG=0
KILL DIC
if Y<0
DO ENDMSG
if Y<0
GOTO EXIT
SET PSORSN=+Y
+1 IF PSO=3
SET DIC="^IBE(350.3,"
SET DIC(0)="QEZ"
SET X="RX EDITED"
DO ^DIC
KILL DIC
if Y<0
GOTO EXIT
SET PSORSN=+Y
+2 if $GET(PSOPFS)
GOTO CANCEL2
+3 SET X=PSOPAR7_"^"_+$PIECE(^PSRX(PSODA,0),"^",2)_"^^"_DUZ
+4 ; Original Rx
if PSOREF=0
SET X(PSORXN)=$SELECT($GET(POTBILL)="":+$PIECE(PSOIB,"^",2),1:POTBILL)_"^"_PSORSN
+5 ; Refill Rx
if PSOREF>0
SET X(PSORXN)=$SELECT($GET(POTBILL)="":+^PSRX(PSODA,1,PSOREF,"IB"),1:POTBILL)_"^"_PSORSN
+6 IF $GET(POTBILL)'=""
DO CANIBAM^IBARX
GOTO CANCEL2
+7 DO CANCEL^IBARX
+8 ; Return y=1 if success, -1^error code if error
+9 ; y(n)=IB number^total charge^AR bill number
+10 IF +Y=-1
WRITE !,"Error in processing...No action taken."
GOTO EXIT
+11 if '$DATA(Y(PSORXN))
GOTO EXIT
CANCEL2 ;only cancel charge if released
IF $GET(PSOPFS)&($GET(PSORD))
DO CHRG^PSOPFSU1(PSODA,PSOREF,"CD",PSOPFS)
+1 if '($PIECE(+$GET(^PSRX(PSODA,"IB")),"^",1))
GOTO EXIT
+2 IF $GET(PSOPFS)
DO PFS2
GOTO EXIT
+3 DO FILE
+4 GOTO EXIT
+5 ;
FILE ;
+1 ;G PFS2:$G(PSOPFS)
+2 ; File new Bill # in ^PSRX
+3 ;...Original Rx
IF '$GET(POTBILL)
if PSOREF=0
SET $PIECE(^PSRX(PSODA,"IB"),"^",2)=+Y(PSORXN)
+4 ; IF POTENTIAL BILL IS CANCELLED, REMOVE ITS NUMBER FROM ^PSRX
IF $GET(POTBILL)
if PSOREF=0
SET $PIECE(^PSRX(PSODA,"IB"),"^",4)=""
+5 ; ...Refill Rx
IF '$GET(POTBILL)
if PSOREF>0
SET ^PSRX(PSODA,1,PSOREF,"IB")=+Y(PSORXN)
+6 ; ...Refill Rx (REMOVE "POTENTIAL" BILL NUMBER WHEN CANCELLED)
IF $GET(POTBILL)
if PSOREF>0
SET $PIECE(^PSRX(PSODA,1,PSOREF,"IB"),"^",2)=""
PFS2 ;
+1 IF PSO=1
WRITE !!,"Co-Pay transaction for Rx # ",PSORXN,$SELECT(PSOREF>0:" refill # "_PSOREF,1:"")," has been cancelled."
SET PREA="C"
SET PSOCOMM="Returned to stock"
+2 IF PSO=2
WRITE !!,"Co-Pay transaction for Rx # ",PSORXN,$SELECT(PSOREF>0:" refill # "_PSOREF,1:"")," has been updated."
SET PREA="E"
SET PSOCOMM="Days supply change. Copay amount updated"
+3 DO ACTLOG
+4 QUIT
+5 ;
UPDATE ;if days supply changes during Rx edit, cancel old bill and get new bill number
+1 NEW SAVEDA
+2 SET SAVEDA=$GET(DA)
+3 IF PSOFLAG=0
WRITE !,"Use Pharmacy Manager Option - Edit Prescriptions - to UPDATE this Rx."
GOTO EXIT
+4 ;
+5 ; Set x=service^dfn^action type^user duz.....x value for update
+6 ; x(n)=softlink^units^IB number of parent to cancel^Cancellation reason
+7 ;
+8 ;
+9 SET X=PSOPAR7_"^"_+$PIECE(^PSRX(PSODA,0),"^",2)_"^"_$PIECE(^PSRX(PSODA,"IB"),"^")_"^"_DUZ
+10 ; Units for COPAY
+11 SET PSOCPUN=$PIECE(($PIECE(^PSRX(PSODA,0),"^",8)+29)/30,".",1)
+12 ; No change if UNITS unchanged
if PSOCPUN=$PIECE((PSODAYS+29)/30,".",1)
GOTO EXIT
+13 ;
+14 ; Build softlink for x(n)
+15 SET X(PSORXN)="52:"_PSODA
if PSOREF>0
SET X(PSORXN)=X(PSORXN)_";1:"_PSOREF
+16 ;
+17 ; Set IB number of Parent record to update
+18 SET PSOPARNT=$SELECT(PSOREF=0:+$PIECE(^PSRX(PSODA,"IB"),"^",2),PSOREF>0:+^PSRX(PSODA,1,PSOREF,"IB"),1:0)
+19 SET X(PSORXN)=X(PSORXN)_"^"_PSOCPUN_"^"_PSOPARNT_"^"_PSORSN
+20 IF $GET(POTBILL)'=""
Begin DoDot:1
+21 SET $PIECE(X(PSORXN),"^",3)=POTBILL
+22 IF $TEXT(UPIBAM^IBARX)=""
QUIT
+23 DO UPIBAM^IBARX
End DoDot:1
+24 IF '$GET(POTBILL)
DO UPDATE^IBARX
+25 ; Return y=1 if success, -1^error code if error
+26 ; y(n)=IB number^total charge^AR bill number
+27 IF +Y=-1
WRITE !,"Error in processing...No action taken."
GOTO EXIT
+28 if '$DATA(Y(PSORXN))
GOTO EXIT
PFS3 ;
+1 DO FILE
+2 GOTO EXIT
+3 ;
RXDEL ; Entry point when Rx is deleted thru menu option -- THIS ENTRY POINT NO LONGER USED WITH MILL BILL COPAY CHANGES
+1 KILL DIC
SET DIC="^IBE(350.3,"
SET DIC(0)="M"
SET X="RX DELETED"
DO ^DIC
KILL DIC
if +Y<0
QUIT
SET PSORSN=+Y
+2 KILL Y
+3 SET PSODA=RXN
SET PSORXN=+RX
+4 SET X=PSOPAR7_"^"_+$PIECE(RX,"^",2)_"^^"_DUZ
+5 ; Original Rx
SET X(PSORXN)=+$PIECE(PSOIB,"^",2)_"^"_PSORSN
+6 DO CANCEL^IBARX
+7 if +Y=1
WRITE !!,"Copay transaction for this Rx has been cancelled."
+8 SET PREA="C"
DO ACTLOG
+9 GOTO EXIT
+10 ;
EXITA ;
+1 IF PSO=1
WRITE !!,"Co-Pay transaction for Rx # ",PSORXN,$SELECT(PSOREF>0:" refill # "_PSOREF,1:"")," has previously been cancelled."
EXIT ;
IF $DATA(SAVEDA)
SET DA=SAVEDA
+1 IF PSO'=3
KILL PSO,PSOCPUN,PSODA,PSOFLAG,PSOIB,PSOPARNT,PSOREF,PSORSN,PSORXN,PSZ,X,Y
QUIT
+2 IF PSO=3
KILL PSOCPUN,PSOPARNT,PSORXN,X,Y
+3 QUIT
+4 ;
ENDMSG ;
+1 IF PSO'=3
WRITE !!,"Unable to UPDATE COPAY TRANSACTON without REMOVAL REASON entry."
+2 QUIT
+3 ;
ACTLOG ;ENTER MESSAGE INTO RX COPAY ACTIVITY LOG
+1 ;don't set copay activity log when no copay when send Rx to external bill sys
IF +$GET(PSOPFS)&('$DATA(^PSRX(PSODA,"IB")))
QUIT
+2 NEW PSODUZ,X,Y
+3 SET PSODUZ=DUZ
+4 IF '$DATA(^VA(200,+PSODUZ,0))
SET PSODUZ=.5
+5 IF '$DATA(PREA)
SET PREA="R"
+6 DO NOW^%DTC
+7 SET PSI=0
ACTL ;
+1 SET PSI=+$ORDER(^PSRX(PSODA,"COPAY",PSI))
+2 IF $ORDER(^PSRX(PSODA,"COPAY",PSI))
GOTO ACTL
+3 KILL DIC,PSORSNZ
+4 IF $GET(PSORSN)'=""
SET DIC="^IBE(350.3,"
SET DIC(0)="M"
SET X="`"_PSORSN
DO ^DIC
KILL DIC
IF $GET(Y)
SET PSORSNZ=$PIECE($GET(Y),"^",2)
+5 SET PSORSNZ=$GET(PSORSNZ)_$SELECT($GET(PSORSNZ)="":"",1:" ")_$GET(PSOCOMM)
+6 SET ^PSRX(PSODA,"COPAY",+PSI+1,0)=%_"^"_PREA_"^"_PSODUZ_"^"_$GET(PSOREF)_"^"_PSORSNZ_"^"_$GET(PSOOLD)_"^"_$GET(PSONW)
+7 SET ^PSRX(PSODA,"COPAY",0)="^52.0107DA^"_(+PSI+1)_"^"_(+PSI+1)
+8 KILL PSORSNZ
+9 QUIT
+10 ;
