- PSORXDL ;BIR/SAB - Deletes one prescription ;08/23/17 20:48
- ;;7.0;OUTPATIENT PHARMACY;**4,17,9,27,117,131,148,201,291,368,408,441**;DEC 1997;Build 208
- ;External reference to ^PS(55 supported by DBIA 2228
- ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
- ;External reference to ^PS(59.7 supported by DBIA 694
- ;External reference to ^PSDRUG( supported by DBIA 221
- I '$D(^XUSEC("PSORPH",DUZ)) W !,$C(7),"Requires Pharmacy Key (PSORPH) !" Q
- I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"SITE PARAMETERS MUST BE DEFINED!",! Q
- K DA,PSODEFLG,PSOHLRE,PSOHLDAH,QTY,PSOABCDA,PSOREF
- S (PSDEL,PSOXXDEL)=1,PS="DELETE",DIC("S")="I $P($G(^(0)),""^"",2),$P($G(^(""STA"")),""^"")'=13,$G(^(2))"
- D A1^PSORXVW K DIC("S") I $G(DA)<1 G KILL
- D FULL^VALM1
- S RXN=+$G(DA)
- S PSORXDFN=+$P($G(^PSRX(RXN,0)),"^",2)
- S PSOPLCK=$$L^PSSLOCK(PSORXDFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY K PSOPLCK G PSORXDL
- K PSOPLCK D PSOL^PSSLOCK(RXN) I '$G(PSOMSG) W !,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),! K PSOMSG D ULP G PSORXDL
- S (REL,PSOGGFL)=0 F PSOGG=0:0 S PSOGG=$O(^PSRX(DA,1,PSOGG)) Q:'PSOGG S:$D(^PSRX(DA,1,PSOGG,0)) PSOGGFL=PSOGG
- S REL=$S($G(PSOGGFL)&($P($G(^PSRX(DA,1,+$G(PSOGGFL),0)),"^",18))&('$P($G(^(0)),"^",16)):1,'$G(PSOGGFL)&($P($G(^PSRX(DA,2)),"^",13))&('$P($G(^(2)),"^",15)):1,1:0)
- I REL W !!,$S($G(PSOGGFL):"Refill number "_$G(PSOGGFL),1:"The Original Fill")," has already been released for Rx # "_$P($G(^PSRX(DA,0)),"^")
- I REL W !,"Drug: ",$P($G(^PSDRUG(+$P($G(^PSRX(DA,0)),"^",6),0)),"^"),?49,$P($G(^DPT(+$P($G(^PSRX(DA,0)),"^",2),0)),"^")
- I REL W ! K DIR S DIR(0)="Y",DIR("A")="Return this fill to stock and delete the prescription",DIR("B")="N" D D ^DIR K DIR G:$G(Y)=1 PASS W !!?5,"No Action Taken.",! D ULK,ULP,KILL G PSORXDL
- .S DIR("?")=" ",DIR("?",1)="Enter 'Y' to return this last fill to stock and continue with the deleting of",DIR("?",2)="this prescription, enter 'N' to exit."
- K DIR S DIR(0)="Y",DIR("A",1)="Are you sure you want to DELETE Rx # "_$P(^PSRX(DA,0),"^"),DIR("A",2)="Drug: "_$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^")
- S DIR("A")="for "_$P(^DPT($P(^PSRX(DA,0),"^",2),0),"^")
- S DIR("B")="NO" D ^DIR D:$D(DTOUT) ULK,ULP G:$D(DTOUT) KILL I $D(DIRUT)!'Y D ULK,ULP,KILL G PSORXDL
- PASS N PSORXDAC K PSOXYZF S PSORXDAC=$O(^PS(52.5,"B",DA,0)) I PSORXDAC,$P($G(^PS(52.5,PSORXDAC,0)),"^",7)="L" N PSOXYZ S PSOXYZF=0 W !!,"Please wait, Rx is Loading for CMOP Transmission.." D
- .F PSOXYZ=1:1:5 W "." H 1 I $P($G(^PS(52.5,PSORXDAC,0)),"^",7)'="L" S PSOXYZF=1
- I $G(PSOXYZF)=0 W !!,"Sorry, still loading for CMOP transmission, try again later.",! D ULK,ULP,KILL K PSOXYZF G PSORXDL
- K PSOXYZF
- I $G(REL) S PSOHLRE=REL,PSOHLDAH=$G(DA)
- I $G(REL) S RXP=DA S PSODEFLG=0 D RESK I $G(PSODEFLG) D ULK,ULP,KILL G PSORXDL
- I $G(PSOHLRE) W !!?5,"Deleting prescription..",! S DA=$G(PSOHLDAH),REL=$G(PSOHLRE)
- S PSOABCDA=$G(DA) D NOOR^PSOCAN4 I $D(DIRUT) W " NO ACTION TAKEN!",! D ULK,ULP,KILL G PSORXDL
- S DA=$G(PSOABCDA) K DIR,PSOABCDA S DIR("A")="Comments",DIR("B")="Per Pharmacy Request",DIR(0)="F^5:100" D ^DIR K DIR I $D(DIRUT) W !!?5,"NO ACTION TAKEN!",! D ULK,ULP G KILL
- I $G(PKI1) N INCOM S INCOM=Y D DCV^PSOPKIV1,ULK,ULP G PSORXDL
- ENQ S PSOIB=$S($D(^PSRX(DA,"IB")):^PSRX(DA,"IB"),1:0) ;Check if copay
- S RX=^PSRX(DA,0),RXN=DA
- S $P(^PSRX(RXN,"STA"),"^")=13,$P(^PSRX(RXN,"D"),"^")=$G(Y)
- S DA=RXN K ^PSRX("ACP",$P(^PSRX(DA,0),"^",2),+$P(^(2),"^",2),0,DA) D ACT
- S DA=RXN I $G(^PSRX(DA,"H"))]"" K ^PSRX("AH",+$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")=""
- D EN^PSOHLSN1(DA,"OC","",$P(^PSRX(DA,"D"),"^"),PSONOOR)
- I $D(^PSRX(DA,"PARK")) K ^PSRX(DA,"PARK"),^PSRX("APARK",1,DA) ;441 PAPI
- S DA=$O(^PS(52.5,"B",RXN,0)) I DA S DIK="^PS(52.5," D ^DIK
- S DA=RXN I $D(^PS(52.4,RXN)) S DIK="^PS(52.4," D ^DIK
- K PSOABCDA I $G(DA) S PSOABCDA=$G(DA)
- I $O(^PS(52.41,"ARF",RXN,0)) S DA=$O(^PS(52.41,"ARF",RXN,0)),DIK="^PS(52.41," D ^DIK K DA,DIK
- I $G(PSOABCDA) S DA=$G(PSOABCDA)
- I $G(PSOABCDA) S DA=$G(PSOABCDA) K PSOABCDA
- Q:+$G(PSORX("INTERVENE"))!($G(PSVFLAG)) I $D(DA),'$G(PSOZVER) D ULK,ULP G PSORXDL
- S ^PSDRUG(+$P(RX,"^",6),660.1)=$S($D(^PSDRUG(+$P(RX,"^",6),660.1)):^(660.1),1:0)+$P(RX,"^",7)
- S DFN=+$P(RX,"^",2) F I=0:0 S I=$O(^PS(55,DFN,"P",I)) Q:'I I +^(I,0)=RXN K ^(0) S ^(0)=$P(^PS(55,DFN,"P",0),"^",1,3)_"^"_($P(^(0),"^",4)-1)
- F I=0:0 S I=$O(^PS(55,DFN,"P","A",I)) Q:'I I $D(^(I,RXN)) K ^(RXN)
- K STAT,COM,RX,RXN Q:+$G(PSORX("INTERVENE"))!($G(PSVFLAG)) I $G(PSDEL) D ULK,ULP G PSORXDL
- ;
- KILL K PSORXDFN,PSOMSG,PSOPLCK,RXO,RX0,RX2,RESK,PSIN,PSODEF,PSOPCECT,PSDEL,I,II,J,N,PHYS,PS,RFDATE,RFL,RFL1,ST,ST0,%,%Y,D0,DA,DI,DIC,DIE,DIH,DIU,DIV,DR,Z,DIG,X,Y,PSOIB,RX,RXN,PSODEFLG,PSOREF,PSOHLRE,PSOHLDAH,PSOGG,PSODLCOM,COPAYFLG
- K DIR,RXP,DIRUT,DUOUT,DTOUT,SIGOK,REL,PSONODF,PSONOOR,PSOGGFL,PSOXYZF,TYPE,XTYPE,QDRUG,QTY,PSOWHERE,PSOLOCRL,PSOCPRX,PSODT,PSODA,PSOINVTX,IFN,PSROF,PSOABCDA,PSOXXDEL,PSOPFS
- Q
- ACT ;adds activity info for deleted rx
- S (RXF,PSOREF)=0 F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I S (RXF,PSOREF)=I S:I>5 RXF=I+1 K ^PSRX("ACP",$P(^PSRX(RXN,0),"^",2),$P(^PSRX(RXN,1,I,0),"^"),I,RXN)
- S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA S DA=FDA
- D NOW^%DTC S DA=DA+1,^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA,^PSRX(RXN,"A",DA,0)=%_"^"_"D"_"^"_DUZ_"^"_RXF_"^"_"RX DELETED on "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)
- EX W !,"...PRESCRIPTION #"_$P(RX,"^")_" MARKED DELETED!!"
- K RXF,I,FDA,DIC,DIE,%,%I,%H S DA=RXN
- ; - Sending Refill to ECME for claim REVERSAL (Rx Delete)
- D REVERSE^PSOBPSU1(RXN,PSOREF,"DE",5,,1)
- Q
- RESK ;
- S RESK=1,PSIN=+$P(^PS(59.7,1,49.99),"^",2) K PSODEF S PSOPCECT=1
- S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(RXP,0),"^",2)) K PSOLOUD
- I $S('+$P($G(^PSRX(+RXP,"STA")),"^"):0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSORESK1 S PSODEFLG=1 Q
- W !!?5,"Returning Medication to Stock..",!
- K DIR,PSODLCOM,COM S DIR(0)="F^10:75",DIR("A")="Comments",DIR("?")="Comments are required, 10-75 characters." W ! D ^DIR K DIR S (COM,PSODLCOM)=Y I Y["^"!($D(DIRUT)) W !!,"No Action Taken!",! S PSODEFLG=1 Q
- S QDRUG=+$P($G(^PSRX(RXP,0)),"^",6),QTY=$P($G(^(0)),"^",7) I $O(^PSRX(RXP,1,0)) G REF
- S XTYPE="O" I $P($G(^PSRX(RXP,2)),"^",15) Q
- I $P($G(^PSRX(RXP,2)),"^",2)<$G(PSIN) Q
- K PSOLOCRL,PSOWHERE S PSOLOCRL=$P($G(^PSRX(RXP,2)),"^",13)
- Q:'$G(PSOLOCRL)
- S PSOWHERE=$S($D(^PSRX("AR",$G(PSOLOCRL),RXP,0)):1,1:0)
- I +$G(^PSRX(RXP,"IB"))!($P($G(^PSRX(RXP,"PFS")),"^",2)) S COPAYFLG=1 N PSOPFS S:$P($G(^PSRX(RXP,"PFS")),"^",2) PSOPFS="1^"_$P(^PSRX(RXP,"PFS"),"^",1,2) D CP^PSORESK1 I '$G(COPAYFLG) S PSODEFLG=1 Q
- I $G(^PSDRUG(QDRUG,660.1)),$G(PSOWHERE) D INVT W:$G(PSODEFLG) !!?5,"No Action Taken!",! Q:$G(PSODEFLG) I $G(PSOINVTX) D INVINC
- I $G(^PSDRUG(QDRUG,660.1)),'$G(PSOWHERE) D INVINC
- I $G(PSOWHERE) K ^PSRX("AR",$G(PSOLOCRL),RXP,0)
- ;
- ; - Preserving Original Fill data on the Return To Stock Log multiple
- D LOGRTS^PSORTSUT(RXP,0)
- ;
- D NOW^%DTC K DIE S DA=RXP,DIE="^PSRX(",DR="31///@;32.1///"_% D ^DIE K DIE
- ;D EN^PSOHLSN1(RXP,"ZD")
- D ACT^PSORESK1
- S DA=$O(^PS(52.5,"B",RXP,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK K DIK
- D EN^PSOHLSN1(RXP,"ZD")
- S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT ;PSO*7*368
- S ^XTMP("PSA",PSOSITE,+QDRUG,+DT)=$G(^XTMP("PSA",PSOSITE,+QDRUG,+DT))-QTY ;PSO*7*368
- W !,"Rx # "_$P($G(^PSRX(RXP,0)),"^")_" Returned to Stock.",!
- ; - Sending Rx to ECME for claim REVERSAL (Return to Stock)
- D REVERSE^PSOBPSU1(RXP,0,"RS",4,,1)
- Q
- REF ;
- K TYPE F PSROF=0:0 S PSROF=$O(^PSRX(RXP,1,PSROF)) Q:'PSROF S:$P($G(^PSRX(RXP,1,PSROF,0)),"^") TYPE=PSROF
- I '$G(TYPE) Q
- S XTYPE=1
- I $P($G(^PSRX(RXP,1,TYPE,0)),"^",16) Q
- I '$P($G(^PSRX(RXP,1,TYPE,0)),"^",18) Q
- I '$P($G(^PSRX(RXP,1,TYPE,0)),"^",18),$P($G(^(0)),"^")'<PSIN Q
- S PSOLOCRL=$P($G(^PSRX(RXP,1,TYPE,0)),"^",18)
- Q:'$G(PSOLOCRL)
- S PSOWHERE=$S($D(^PSRX("AR",$G(PSOLOCRL),RXP,TYPE)):1,1:0)
- S QTY=$P($G(^PSRX(RXP,1,TYPE,0)),"^",4)
- I +$G(^PSRX(RXP,"IB"))!($P($G(^PSRX(RXP,1,TYPE,"PFS")),"^",2)) S COPAYFLG=1 N PSOPFS S:$P($G(^PSRX(RXP,1,TYPE,"PFS")),"^",2) PSOPFS="1^"_$P(^PSRX(RXP,1,TYPE,"PFS"),"^",1,2) D CP^PSORESK1 I '$G(COPAYFLG) S PSODEFLG=1 Q
- I $G(^PSDRUG(QDRUG,660.1)),$G(PSOWHERE) D INVT W:$G(PSODEFLG) !!?5,"No Action Taken!",! Q:$G(PSODEFLG) I $G(PSOINVTX) D INVINC
- I $G(^PSDRUG(QDRUG,660.1)),'$G(PSOWHERE) D INVINC
- I $G(PSOWHERE) K ^PSRX("AR",$G(PSOLOCRL),RXP,TYPE)
- ;
- ; - Preserving Refill data on the Return To Stock Log multiple (before it gets deleted)
- D LOGRTS^PSORTSUT(RXP,TYPE)
- ;
- D NOW^%DTC K DIE S DA(1)=RXP,DA=TYPE,DIE="^PSRX("_DA(1)_",1,",DR="17////@;.01///@" W ! D ^DIE K DIE
- ;D EN^PSOHLSN1(RXP,"ZD")
- D ACT^PSORESK1
- S DA=$O(^PS(52.5,"B",RXP,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK K DIK
- S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT ;PSO*7*368
- S ^XTMP("PSA",PSOSITE,+QDRUG,+DT)=$G(^XTMP("PSA",PSOSITE,+QDRUG,+DT))-QTY ;PSO*7*368
- D EN^PSOHLSN1(RXP,"ZD") W !,"Rx # "_$P($G(^PSRX(RXP,0)),"^")_" Refill Returned to Stock.",!
- ; - Sending Rx refill to ECME for claim REVERSAL (Return to Stock)
- D REVERSE^PSOBPSU1(RXP,TYPE,"RS",4,,1)
- Q
- INVT ;
- S PSOINVTX=0
- K DIR,DIRUT S DIR(0)="Y",DIR("B")="N",DIR("A")="This is a CMOP Rx, do you want to increment the local inventory" D W ! D ^DIR K DIR S:$D(DIRUT) PSODEFLG=1 Q:$G(PSODEFLG) I $G(Y)=1 S PSOINVTX=1
- .S DIR("?")=" ",DIR("?",1)="Enter 'Y' if you want to increment the local inventory with the Quantity that",DIR("?",2)="has been released at the CMOP"
- Q
- INVINC ;
- S ^PSDRUG(QDRUG,660.1)=$S($P($G(^PSDRUG(QDRUG,660.1)),"^"):$P($G(^PSDRUG(QDRUG,660.1)),"^"),1:0)+$G(QTY)
- Q
- ;
- ULK ;
- I $G(RXN) D PSOUL^PSSLOCK(RXN)
- Q
- ULP ;
- D UL^PSSLOCK(+$G(PSORXDFN))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORXDL 9786 printed Feb 19, 2025@00:00:52 Page 2
- PSORXDL ;BIR/SAB - Deletes one prescription ;08/23/17 20:48
- +1 ;;7.0;OUTPATIENT PHARMACY;**4,17,9,27,117,131,148,201,291,368,408,441**;DEC 1997;Build 208
- +2 ;External reference to ^PS(55 supported by DBIA 2228
- +3 ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
- +4 ;External reference to ^PS(59.7 supported by DBIA 694
- +5 ;External reference to ^PSDRUG( supported by DBIA 221
- +6 IF '$DATA(^XUSEC("PSORPH",DUZ))
- WRITE !,$CHAR(7),"Requires Pharmacy Key (PSORPH) !"
- QUIT
- +7 IF '$DATA(PSOPAR)
- DO ^PSOLSET
- IF '$DATA(PSOPAR)
- WRITE $CHAR(7),!!,"SITE PARAMETERS MUST BE DEFINED!",!
- QUIT
- +8 KILL DA,PSODEFLG,PSOHLRE,PSOHLDAH,QTY,PSOABCDA,PSOREF
- +9 SET (PSDEL,PSOXXDEL)=1
- SET PS="DELETE"
- SET DIC("S")="I $P($G(^(0)),""^"",2),$P($G(^(""STA"")),""^"")'=13,$G(^(2))"
- +10 DO A1^PSORXVW
- KILL DIC("S")
- IF $GET(DA)<1
- GOTO KILL
- +11 DO FULL^VALM1
- +12 SET RXN=+$GET(DA)
- +13 SET PSORXDFN=+$PIECE($GET(^PSRX(RXN,0)),"^",2)
- +14 SET PSOPLCK=$$L^PSSLOCK(PSORXDFN,0)
- IF '$GET(PSOPLCK)
- DO LOCK^PSOORCPY
- KILL PSOPLCK
- GOTO PSORXDL
- +15 KILL PSOPLCK
- DO PSOL^PSSLOCK(RXN)
- IF '$GET(PSOMSG)
- WRITE !,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing this order."),!
- KILL PSOMSG
- DO ULP
- GOTO PSORXDL
- +16 SET (REL,PSOGGFL)=0
- FOR PSOGG=0:0
- SET PSOGG=$ORDER(^PSRX(DA,1,PSOGG))
- if 'PSOGG
- QUIT
- if $DATA(^PSRX(DA,1,PSOGG,0))
- SET PSOGGFL=PSOGG
- +17 SET REL=$SELECT($GET(PSOGGFL)&($PIECE($GET(^PSRX(DA,1,+$GET(PSOGGFL),0)),"^",18))&('$PIECE($GET(^(0)),"^",16)):1,'$GET(PSOGGFL)&($PIECE($GET(^PSRX(DA,2)),"^",13))&('$PIECE($GET(^(2)),"^",15)):1,1:0)
- +18 IF REL
- WRITE !!,$SELECT($GET(PSOGGFL):"Refill number "_$GET(PSOGGFL),1:"The Original Fill")," has already been released for Rx # "_$PIECE($GET(^PSRX(DA,0)),"^")
- +19 IF REL
- WRITE !,"Drug: ",$PIECE($GET(^PSDRUG(+$PIECE($GET(^PSRX(DA,0)),"^",6),0)),"^"),?49,$PIECE($GET(^DPT(+$PIECE($GET(^PSRX(DA,0)),"^",2),0)),"^")
- +20 IF REL
- WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Return this fill to stock and delete the prescription"
- SET DIR("B")="N"
- Begin DoDot:1
- +21 SET DIR("?")=" "
- SET DIR("?",1)="Enter 'Y' to return this last fill to stock and continue with the deleting of"
- SET DIR("?",2)="this prescription, enter 'N' to exit."
- End DoDot:1
- DO ^DIR
- KILL DIR
- if $GET(Y)=1
- GOTO PASS
- WRITE !!?5,"No Action Taken.",!
- DO ULK
- DO ULP
- DO KILL
- GOTO PSORXDL
- +22 KILL DIR
- SET DIR(0)="Y"
- SET DIR("A",1)="Are you sure you want to DELETE Rx # "_$PIECE(^PSRX(DA,0),"^")
- SET DIR("A",2)="Drug: "_$PIECE(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0),"^")
- +23 SET DIR("A")="for "_$PIECE(^DPT($PIECE(^PSRX(DA,0),"^",2),0),"^")
- +24 SET DIR("B")="NO"
- DO ^DIR
- if $DATA(DTOUT)
- DO ULK
- DO ULP
- if $DATA(DTOUT)
- GOTO KILL
- IF $DATA(DIRUT)!'Y
- DO ULK
- DO ULP
- DO KILL
- GOTO PSORXDL
- PASS NEW PSORXDAC
- KILL PSOXYZF
- SET PSORXDAC=$ORDER(^PS(52.5,"B",DA,0))
- IF PSORXDAC
- IF $PIECE($GET(^PS(52.5,PSORXDAC,0)),"^",7)="L"
- NEW PSOXYZ
- SET PSOXYZF=0
- WRITE !!,"Please wait, Rx is Loading for CMOP Transmission.."
- Begin DoDot:1
- +1 FOR PSOXYZ=1:1:5
- WRITE "."
- HANG 1
- IF $PIECE($GET(^PS(52.5,PSORXDAC,0)),"^",7)'="L"
- SET PSOXYZF=1
- End DoDot:1
- +2 IF $GET(PSOXYZF)=0
- WRITE !!,"Sorry, still loading for CMOP transmission, try again later.",!
- DO ULK
- DO ULP
- DO KILL
- KILL PSOXYZF
- GOTO PSORXDL
- +3 KILL PSOXYZF
- +4 IF $GET(REL)
- SET PSOHLRE=REL
- SET PSOHLDAH=$GET(DA)
- +5 IF $GET(REL)
- SET RXP=DA
- SET PSODEFLG=0
- DO RESK
- IF $GET(PSODEFLG)
- DO ULK
- DO ULP
- DO KILL
- GOTO PSORXDL
- +6 IF $GET(PSOHLRE)
- WRITE !!?5,"Deleting prescription..",!
- SET DA=$GET(PSOHLDAH)
- SET REL=$GET(PSOHLRE)
- +7 SET PSOABCDA=$GET(DA)
- DO NOOR^PSOCAN4
- IF $DATA(DIRUT)
- WRITE " NO ACTION TAKEN!",!
- DO ULK
- DO ULP
- DO KILL
- GOTO PSORXDL
- +8 SET DA=$GET(PSOABCDA)
- KILL DIR,PSOABCDA
- SET DIR("A")="Comments"
- SET DIR("B")="Per Pharmacy Request"
- SET DIR(0)="F^5:100"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- WRITE !!?5,"NO ACTION TAKEN!",!
- DO ULK
- DO ULP
- GOTO KILL
- +9 IF $GET(PKI1)
- NEW INCOM
- SET INCOM=Y
- DO DCV^PSOPKIV1
- DO ULK
- DO ULP
- GOTO PSORXDL
- ENQ ;Check if copay
- SET PSOIB=$SELECT($DATA(^PSRX(DA,"IB")):^PSRX(DA,"IB"),1:0)
- +1 SET RX=^PSRX(DA,0)
- SET RXN=DA
- +2 SET $PIECE(^PSRX(RXN,"STA"),"^")=13
- SET $PIECE(^PSRX(RXN,"D"),"^")=$GET(Y)
- +3 SET DA=RXN
- KILL ^PSRX("ACP",$PIECE(^PSRX(DA,0),"^",2),+$PIECE(^(2),"^",2),0,DA)
- DO ACT
- +4 SET DA=RXN
- IF $GET(^PSRX(DA,"H"))]""
- KILL ^PSRX("AH",+$PIECE(^PSRX(DA,"H"),"^"),DA)
- SET ^PSRX(DA,"H")=""
- +5 DO EN^PSOHLSN1(DA,"OC","",$PIECE(^PSRX(DA,"D"),"^"),PSONOOR)
- +6 ;441 PAPI
- IF $DATA(^PSRX(DA,"PARK"))
- KILL ^PSRX(DA,"PARK"),^PSRX("APARK",1,DA)
- +7 SET DA=$ORDER(^PS(52.5,"B",RXN,0))
- IF DA
- SET DIK="^PS(52.5,"
- DO ^DIK
- +8 SET DA=RXN
- IF $DATA(^PS(52.4,RXN))
- SET DIK="^PS(52.4,"
- DO ^DIK
- +9 KILL PSOABCDA
- IF $GET(DA)
- SET PSOABCDA=$GET(DA)
- +10 IF $ORDER(^PS(52.41,"ARF",RXN,0))
- SET DA=$ORDER(^PS(52.41,"ARF",RXN,0))
- SET DIK="^PS(52.41,"
- DO ^DIK
- KILL DA,DIK
- +11 IF $GET(PSOABCDA)
- SET DA=$GET(PSOABCDA)
- +12 IF $GET(PSOABCDA)
- SET DA=$GET(PSOABCDA)
- KILL PSOABCDA
- +13 if +$GET(PSORX("INTERVENE"))!($GET(PSVFLAG))
- QUIT
- IF $DATA(DA)
- IF '$GET(PSOZVER)
- DO ULK
- DO ULP
- GOTO PSORXDL
- +14 SET ^PSDRUG(+$PIECE(RX,"^",6),660.1)=$SELECT($DATA(^PSDRUG(+$PIECE(RX,"^",6),660.1)):^(660.1),1:0)+$PIECE(RX,"^",7)
- +15 SET DFN=+$PIECE(RX,"^",2)
- FOR I=0:0
- SET I=$ORDER(^PS(55,DFN,"P",I))
- if 'I
- QUIT
- IF +^(I,0)=RXN
- KILL ^(0)
- SET ^(0)=$PIECE(^PS(55,DFN,"P",0),"^",1,3)_"^"_($PIECE(^(0),"^",4)-1)
- +16 FOR I=0:0
- SET I=$ORDER(^PS(55,DFN,"P","A",I))
- if 'I
- QUIT
- IF $DATA(^(I,RXN))
- KILL ^(RXN)
- +17 KILL STAT,COM,RX,RXN
- if +$GET(PSORX("INTERVENE"))!($GET(PSVFLAG))
- QUIT
- IF $GET(PSDEL)
- DO ULK
- DO ULP
- GOTO PSORXDL
- +18 ;
- KILL KILL PSORXDFN,PSOMSG,PSOPLCK,RXO,RX0,RX2,RESK,PSIN,PSODEF,PSOPCECT,PSDEL,I,II,J,N,PHYS,PS,RFDATE,RFL,RFL1,ST,ST0,%,%Y,D0,DA,DI,DIC,DIE,DIH,DIU,DIV,DR,Z,DIG,X,Y,PSOIB,RX,RXN,PSODEFLG,PSOREF,PSOHLRE,PSOHLDAH,PSOGG,PSODLCOM,COPAYFLG
- +1 KILL DIR,RXP,DIRUT,DUOUT,DTOUT,SIGOK,REL,PSONODF,PSONOOR,PSOGGFL,PSOXYZF,TYPE,XTYPE,QDRUG,QTY,PSOWHERE,PSOLOCRL,PSOCPRX,PSODT,PSODA,PSOINVTX,IFN,PSROF,PSOABCDA,PSOXXDEL,PSOPFS
- +2 QUIT
- ACT ;adds activity info for deleted rx
- +1 SET (RXF,PSOREF)=0
- FOR I=0:0
- SET I=$ORDER(^PSRX(RXN,1,I))
- if 'I
- QUIT
- SET (RXF,PSOREF)=I
- if I>5
- SET RXF=I+1
- KILL ^PSRX("ACP",$PIECE(^PSRX(RXN,0),"^",2),$PIECE(^PSRX(RXN,1,I,0),"^"),I,RXN)
- +2 SET DA=0
- FOR FDA=0:0
- SET FDA=$ORDER(^PSRX(RXN,"A",FDA))
- if 'FDA
- QUIT
- SET DA=FDA
- +3 DO NOW^%DTC
- SET DA=DA+1
- SET ^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA
- SET ^PSRX(RXN,"A",DA,0)=%_"^"_"D"_"^"_DUZ_"^"_RXF_"^"_"RX DELETED on "_$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3)
- EX WRITE !,"...PRESCRIPTION #"_$PIECE(RX,"^")_" MARKED DELETED!!"
- +1 KILL RXF,I,FDA,DIC,DIE,%,%I,%H
- SET DA=RXN
- +2 ; - Sending Refill to ECME for claim REVERSAL (Rx Delete)
- +3 DO REVERSE^PSOBPSU1(RXN,PSOREF,"DE",5,,1)
- +4 QUIT
- RESK ;
- +1 SET RESK=1
- SET PSIN=+$PIECE(^PS(59.7,1,49.99),"^",2)
- KILL PSODEF
- SET PSOPCECT=1
- +2 SET PSOLOUD=1
- if $PIECE($GET(^PS(55,+$PIECE(^PSRX(RXP,0),"^",2),0)),"^",6)'=2
- DO EN^PSOHLUP($PIECE(^PSRX(RXP,0),"^",2))
- KILL PSOLOUD
- +3 IF $SELECT('+$PIECE($GET(^PSRX(+RXP,"STA")),"^"):0,$PIECE(^("STA"),"^")=11:0,$PIECE(^("STA"),"^")=12:0,$PIECE(^("STA"),"^")=14:0,$PIECE(^("STA"),"^")=15:0,1:1)
- DO STAT^PSORESK1
- SET PSODEFLG=1
- QUIT
- +4 WRITE !!?5,"Returning Medication to Stock..",!
- +5 KILL DIR,PSODLCOM,COM
- SET DIR(0)="F^10:75"
- SET DIR("A")="Comments"
- SET DIR("?")="Comments are required, 10-75 characters."
- WRITE !
- DO ^DIR
- KILL DIR
- SET (COM,PSODLCOM)=Y
- IF Y["^"!($DATA(DIRUT))
- WRITE !!,"No Action Taken!",!
- SET PSODEFLG=1
- QUIT
- +6 SET QDRUG=+$PIECE($GET(^PSRX(RXP,0)),"^",6)
- SET QTY=$PIECE($GET(^(0)),"^",7)
- IF $ORDER(^PSRX(RXP,1,0))
- GOTO REF
- +7 SET XTYPE="O"
- IF $PIECE($GET(^PSRX(RXP,2)),"^",15)
- QUIT
- +8 IF $PIECE($GET(^PSRX(RXP,2)),"^",2)<$GET(PSIN)
- QUIT
- +9 KILL PSOLOCRL,PSOWHERE
- SET PSOLOCRL=$PIECE($GET(^PSRX(RXP,2)),"^",13)
- +10 if '$GET(PSOLOCRL)
- QUIT
- +11 SET PSOWHERE=$SELECT($DATA(^PSRX("AR",$GET(PSOLOCRL),RXP,0)):1,1:0)
- +12 IF +$GET(^PSRX(RXP,"IB"))!($PIECE($GET(^PSRX(RXP,"PFS")),"^",2))
- SET COPAYFLG=1
- NEW PSOPFS
- if $PIECE($GET(^PSRX(RXP,"PFS")),"^",2)
- SET PSOPFS="1^"_$PIECE(^PSRX(RXP,"PFS"),"^",1,2)
- DO CP^PSORESK1
- IF '$GET(COPAYFLG)
- SET PSODEFLG=1
- QUIT
- +13 IF $GET(^PSDRUG(QDRUG,660.1))
- IF $GET(PSOWHERE)
- DO INVT
- if $GET(PSODEFLG)
- WRITE !!?5,"No Action Taken!",!
- if $GET(PSODEFLG)
- QUIT
- IF $GET(PSOINVTX)
- DO INVINC
- +14 IF $GET(^PSDRUG(QDRUG,660.1))
- IF '$GET(PSOWHERE)
- DO INVINC
- +15 IF $GET(PSOWHERE)
- KILL ^PSRX("AR",$GET(PSOLOCRL),RXP,0)
- +16 ;
- +17 ; - Preserving Original Fill data on the Return To Stock Log multiple
- +18 DO LOGRTS^PSORTSUT(RXP,0)
- +19 ;
- +20 DO NOW^%DTC
- KILL DIE
- SET DA=RXP
- SET DIE="^PSRX("
- SET DR="31///@;32.1///"_%
- DO ^DIE
- KILL DIE
- +21 ;D EN^PSOHLSN1(RXP,"ZD")
- +22 DO ACT^PSORESK1
- +23 SET DA=$ORDER(^PS(52.5,"B",RXP,0))
- IF DA
- KILL DIK
- SET DIK="^PS(52.5,"
- DO ^DIK
- KILL DIK
- +24 DO EN^PSOHLSN1(RXP,"ZD")
- +25 ;PSO*7*368
- if '$PIECE($GET(^XTMP("PSA",0)),U,2)
- SET $PIECE(^(0),U,2)=DT
- +26 ;PSO*7*368
- SET ^XTMP("PSA",PSOSITE,+QDRUG,+DT)=$GET(^XTMP("PSA",PSOSITE,+QDRUG,+DT))-QTY
- +27 WRITE !,"Rx # "_$PIECE($GET(^PSRX(RXP,0)),"^")_" Returned to Stock.",!
- +28 ; - Sending Rx to ECME for claim REVERSAL (Return to Stock)
- +29 DO REVERSE^PSOBPSU1(RXP,0,"RS",4,,1)
- +30 QUIT
- REF ;
- +1 KILL TYPE
- FOR PSROF=0:0
- SET PSROF=$ORDER(^PSRX(RXP,1,PSROF))
- if 'PSROF
- QUIT
- if $PIECE($GET(^PSRX(RXP,1,PSROF,0)),"^")
- SET TYPE=PSROF
- +2 IF '$GET(TYPE)
- QUIT
- +3 SET XTYPE=1
- +4 IF $PIECE($GET(^PSRX(RXP,1,TYPE,0)),"^",16)
- QUIT
- +5 IF '$PIECE($GET(^PSRX(RXP,1,TYPE,0)),"^",18)
- QUIT
- +6 IF '$PIECE($GET(^PSRX(RXP,1,TYPE,0)),"^",18)
- IF $PIECE($GET(^(0)),"^")'<PSIN
- QUIT
- +7 SET PSOLOCRL=$PIECE($GET(^PSRX(RXP,1,TYPE,0)),"^",18)
- +8 if '$GET(PSOLOCRL)
- QUIT
- +9 SET PSOWHERE=$SELECT($DATA(^PSRX("AR",$GET(PSOLOCRL),RXP,TYPE)):1,1:0)
- +10 SET QTY=$PIECE($GET(^PSRX(RXP,1,TYPE,0)),"^",4)
- +11 IF +$GET(^PSRX(RXP,"IB"))!($PIECE($GET(^PSRX(RXP,1,TYPE,"PFS")),"^",2))
- SET COPAYFLG=1
- NEW PSOPFS
- if $PIECE($GET(^PSRX(RXP,1,TYPE,"PFS")),"^",2)
- SET PSOPFS="1^"_$PIECE(^PSRX(RXP,1,TYPE,"PFS"),"^",1,2)
- DO CP^PSORESK1
- IF '$GET(COPAYFLG)
- SET PSODEFLG=1
- QUIT
- +12 IF $GET(^PSDRUG(QDRUG,660.1))
- IF $GET(PSOWHERE)
- DO INVT
- if $GET(PSODEFLG)
- WRITE !!?5,"No Action Taken!",!
- if $GET(PSODEFLG)
- QUIT
- IF $GET(PSOINVTX)
- DO INVINC
- +13 IF $GET(^PSDRUG(QDRUG,660.1))
- IF '$GET(PSOWHERE)
- DO INVINC
- +14 IF $GET(PSOWHERE)
- KILL ^PSRX("AR",$GET(PSOLOCRL),RXP,TYPE)
- +15 ;
- +16 ; - Preserving Refill data on the Return To Stock Log multiple (before it gets deleted)
- +17 DO LOGRTS^PSORTSUT(RXP,TYPE)
- +18 ;
- +19 DO NOW^%DTC
- KILL DIE
- SET DA(1)=RXP
- SET DA=TYPE
- SET DIE="^PSRX("_DA(1)_",1,"
- SET DR="17////@;.01///@"
- WRITE !
- DO ^DIE
- KILL DIE
- +20 ;D EN^PSOHLSN1(RXP,"ZD")
- +21 DO ACT^PSORESK1
- +22 SET DA=$ORDER(^PS(52.5,"B",RXP,0))
- IF DA
- KILL DIK
- SET DIK="^PS(52.5,"
- DO ^DIK
- KILL DIK
- +23 ;PSO*7*368
- if '$PIECE($GET(^XTMP("PSA",0)),U,2)
- SET $PIECE(^(0),U,2)=DT
- +24 ;PSO*7*368
- SET ^XTMP("PSA",PSOSITE,+QDRUG,+DT)=$GET(^XTMP("PSA",PSOSITE,+QDRUG,+DT))-QTY
- +25 DO EN^PSOHLSN1(RXP,"ZD")
- WRITE !,"Rx # "_$PIECE($GET(^PSRX(RXP,0)),"^")_" Refill Returned to Stock.",!
- +26 ; - Sending Rx refill to ECME for claim REVERSAL (Return to Stock)
- +27 DO REVERSE^PSOBPSU1(RXP,TYPE,"RS",4,,1)
- +28 QUIT
- INVT ;
- +1 SET PSOINVTX=0
- +2 KILL DIR,DIRUT
- SET DIR(0)="Y"
- SET DIR("B")="N"
- SET DIR("A")="This is a CMOP Rx, do you want to increment the local inventory"
- Begin DoDot:1
- +3 SET DIR("?")=" "
- SET DIR("?",1)="Enter 'Y' if you want to increment the local inventory with the Quantity that"
- SET DIR("?",2)="has been released at the CMOP"
- End DoDot:1
- WRITE !
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- SET PSODEFLG=1
- if $GET(PSODEFLG)
- QUIT
- IF $GET(Y)=1
- SET PSOINVTX=1
- +4 QUIT
- INVINC ;
- +1 SET ^PSDRUG(QDRUG,660.1)=$SELECT($PIECE($GET(^PSDRUG(QDRUG,660.1)),"^"):$PIECE($GET(^PSDRUG(QDRUG,660.1)),"^"),1:0)+$GET(QTY)
- +2 QUIT
- +3 ;
- ULK ;
- +1 IF $GET(RXN)
- DO PSOUL^PSSLOCK(RXN)
- +2 QUIT
- ULP ;
- +1 DO UL^PSSLOCK(+$GET(PSORXDFN))
- +2 QUIT