- 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 Feb 18, 2025@23:52:08 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 ;