PSOHLDC ;BIR/RTR-Process incoming cancel messages from CHCS ;09/06/02
;;7.0;OUTPATIENT PHARMACY;**111,121,146,223,148,249**;DEC 1997;Build 9
;External reference to ^PSSLOCK supported by DBIA 2789
;
ENDC ;
;Process exceptions
N DA,PSOEXINP,PSOHLINR,PSOHLSTP,PSOHLSTR,PSOHLPL,PSOHLCM,PSOCANRC,PSOCANRN,PSOHUIOR
S (PSOHBDS,PSOEXXQ)=0
I PSOHDFOR S PSOEXMS="Invalid message structure." D NAK^PSOHLEXC Q
F PSOHMSG="MSH","PID","ORC" Q:PSOEXXQ I '$D(PSOHLMIS(PSOHMSG)) S PSOEXMS="Missing "_PSOHMSG_" segment." S PSOHBDS=1 D NAK^PSOHLEXC
I $G(PSOEXXQ) Q
I $G(HL("SAN"))="" S PSOEXMS="Missing sending application name." D NAK^PSOHLEXC Q
S PSOHY("EXAPP")=HL("SAN")
I '$G(PSOHY("PAT"))!('$D(^DPT(+$G(PSOHY("PAT")),0))) S PSOEXMS="Invalid patient entry." D NAK^PSOHLEXC Q
I $G(PSOHY("CHNUM"))="" S PSOEXMS="Missing CHCS Placer Order Number." D NAK^PSOHLEXC Q
D CAN^PSOHLEXC
I $G(PSOEXXQ) Q
S (PSOEXINP,PSOHLINR)=0
S PSOEXINP=$O(^PS(52.41,"C",PSOHY("CHNUM"),PSOHY("EXAPP"),0)) I PSOEXINP D PEND Q
S PSOHLINR=$O(^PSRX("D",PSOHY("CHNUM"),PSOHY("EXAPP"),0)) I PSOHLINR D RX Q
S PSOEXMS="Unable to find order in Pharmacy." D NAK^PSOHLEXC
Q
PEND ;Process a DC message on a Pending order
I PSOHY("PAT")'=$P($G(^PS(52.41,PSOEXINP,0)),"^",2) S PSOEXMS="Patient mismatch in Pending order." D NAK^PSOHLEXC Q
K PSOMSG D PSOL^PSSLOCK(+PSOEXINP_"S") I '$G(PSOMSG) S PSOEXMS="Pending order is being edited by another user." D NAK^PSOHLEXC K PSOMSG Q
K PSOMSG
S PSOHLSTP=$P($G(^PS(52.41,PSOEXINP,0)),"^",3)
I PSOHLSTP'="NW" D D NAK^PSOHLEXC Q
.S PSOEXMS="Unable to cancel Pending order, status is "_$S(PSOHLSTP="HD":"HOLD",PSOHLSTP="RNW":"RENEW",PSOHLSTP="DE":"DISCONTINUE (EDIT)",PSOHLSTP="DC":"DISCONTINUE",PSOHLSTP="RF":"REFILL REQUEST",1:"UNKNOWN")_"."
S $P(^PS(52.41,PSOEXINP,0),"^",3)="DC"
S PSOHLPL=$P(^PS(52.41,PSOEXINP,0),"^")
K ^PS(52.41,"AOR",+$P($G(^PS(52.41,PSOEXINP,0)),"^",2),+$P($G(^PS(52.41,PSOEXINP,"INI")),"^"),PSOEXINP)
S PSOHLCM="Discontinued by Provider."
S $P(^PS(52.41,PSOEXINP,4),"^")=PSOHLCM
D PVSET
S PSOHUIOR=1
I PSOHLPL D EN^PSOHLSN(PSOHLPL,"OC",PSOHLCM,"")
D PSOUL^PSSLOCK(+PSOEXINP_"S")
D ACK^PSOHLEXC
K PSOHUIOR
Q
RX ;Process a DC message on a prescription
N PSOSUSD,PSOIFN,PSORFDT,PSOHTEST,PSOHPDA,CMOP,ACOM,PSOARECX,PSODFN
S PSOARECX=0
I PSOHY("PAT")'=$P($G(^PSRX(PSOHLINR,0)),"^",2) S PSOEXMS="Patient mismatch in prescription." D NAK^PSOHLEXC Q
S PSODFN=$P($G(^PSRX(PSOHLINR,0)),"^",2)
K PSOMSG D PSOL^PSSLOCK(PSOHLINR) I '$G(PSOMSG) S PSOEXMS="Prescription is being edited by another user." D NAK^PSOHLEXC K PSOMSG Q
K PSOMSG
S PSOHLSTR=$P($G(^PSRX(PSOHLINR,"STA")),"^")
I PSOHLSTR>11,PSOHLSTR<16 D D NAK^PSOHLEXC Q
.S PSOEXMS="Unable to cancel prescription, status is "_$S(PSOHLSTR=12:"DISCONTINUED",PSOHLSTR=13:"DELETED",PSOHLSTR=14:"DISCONTINUED BY PROVIDER",1:"DISCONTINUED (EDIT)")_"."
S (PSOHLCM,ACOM)="Discontinued by Provider."
I PSOHLSTR=3!(PSOHLSTR=16) D
.S (PSOHLCM,ACOM)="Discontinued by Provider while on hold." K:$P($G(^PSRX(PSOHLINR,"H")),"^") ^PSRX("AH",$P($G(^PSRX(PSOHLINR,"H")),"^"),PSOHLINR) S ^PSRX(PSOHLINR,"H")=""
.I $P(^PSRX(PSOHLINR,0),"^",13),'$O(^PSRX(PSOHLINR,1,0)) S DIE=52,DR="22///"_$E($P(^PSRX(PSOHLINR,0),"^",13),1,7),DA=PSOHLINR D ^DIE K DIE,DA,DR Q
.S (PSOIFN,PSOSUSD)=0,PSORFDT="" F S PSOIFN=$O(^PSRX(PSOHLINR,1,PSOIFN)) Q:'PSOIFN S PSOSUSD=PSOIFN,PSORFDT=$P($G(^PSRX(PSOHLINR,1,PSOIFN,0)),"^")
.I $G(PSORFDT)=""!('$G(PSOSUSD)) Q
.I '$P($G(^PSRX(PSOHLINR,1,PSOSUSD,0)),"^",18) S PSOHTEST=0 D I 'PSOHTEST K ^PSRX(PSOHLINR,1,PSOSUSD),^PSRX("AD",PSORFDT,PSOHLINR,PSOSUSD),^PSRX(PSOHLINR,1,"B",PSORFDT,PSOSUSD),PSOIFN,PSOSUSD,PSORFDT
..F PSOHPDA=0:0 S PSOHPDA=$O(^PSRX(PSOHLINR,"L",PSOHPDA)) Q:'PSOHPDA I $P($G(^PSRX(PSOHLINR,"L",PSOHPDA,0)),"^",2)=PSOSUSD S PSOHTEST=1
..K CMOP S DA=PSOHLINR D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q
..S PSOHTEST=1
D SUS
I '$G(PSOARECX) D ACTL
S $P(^PSRX(PSOHLINR,"STA"),"^")=14,$P(^PSRX(PSOHLINR,3),"^",5)=DT
D CAN^PSOTPCAN(PSOHLINR),REVERSE^PSOBPSU1(PSOHLINR,,"DC",7)
I $O(^PS(52.41,"ARF",PSOHLINR,0)),'$O(^PS(52.41,"APSOD",PSODFN,0)) S DA=$O(^PS(52.41,"ARF",PSOHLINR,0)),DIK="^PS(52.41," D ^DIK K DIK
D PVSET
S PSOHUIOR=1
D EN^PSOHLSN1(PSOHLINR,"OD","","Discontinued by Provider","")
K PSOHUIOR
I $G(^PS(52.4,PSOHLINR,0))]"" S DA=PSOHLINR,DIK="^PS(52.4," D ^DIK K DIK
D PSOUL^PSSLOCK(PSOHLINR)
D ACK^PSOHLEXC
Q
SUS N RXDA,SUSDA,IFN,PSORFDEL,SUSD,RF,NODE
S RXDA=PSOHLINR,(DA,SUSDA)=$O(^PS(52.5,"B",PSOHLINR,0)) D:DA
.S SUSD=$P($G(^PS(52.5,DA,0)),"^",2)
.S:+$G(^PS(52.5,DA,"P"))'=1 (PSOHLCM,ACOM)="Discontinued by Provider while suspended."
.I $O(^PSRX(PSOHLINR,1,0)) S PSOARECX=1 D ACTL S DA=PSOHLINR D:'$G(^PS(52.5,+SUSDA,"P")) REF^PSOCAN2
.I $P($G(^PS(52.5,+SUSDA,0)),"^",2),$P($G(^(0)),"^",3) S DA=SUSDA,DIK="^PS(52.5," D ^DIK K DIK
Q
ACTL ;Add Activity log
N PSORXREF,REA,PSOACNT,PSOSIBB,PSORFH,PSORFCNT
S PSORXREF=0,PSODFN=+$P(^PSRX(PSOHLINR,0),"^",2) D
.S PSOACNT=0 F PSOSUBB=0:0 S PSOSUBB=$O(^PSRX(PSOHLINR,"A",PSOSUBB)) Q:'PSOSUBB S PSOACNT=PSOSUBB
.S PSORFCNT=0 F PSORFH=0:0 S PSORFH=$O(^PSRX(PSOHLINR,1,PSORFH)) Q:'PSORFH S PSORFCNT=PSORFH S:PSORFH>5 PSORFCNT=PSORFH+1
.D NOW^%DTC S ^PSRX(PSOHLINR,"A",0)="^52.3DA^"_(PSOACNT+1)_"^"_(PSOACNT+1),^PSRX(PSOHLINR,"A",PSOACNT+1,0)=%_"^C^"_$G(PSOHY("PROV"))_"^"_PSORFCNT_"^"_$G(PSOHLCM)
.S REA="C" S DA=PSOHLINR N EXP,PCD,IFN D EXP^PSOHELP1
Q
PVSET ;
N DIC,X,Y,USER1
D USER^PSOORFI2(PSOHY("PROV"))
S PSOCANRC=PSOHY("PROV"),PSOCANRN=USER1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLDC 5577 printed Apr 09, 2024@21:36:04 Page 2
PSOHLDC ;BIR/RTR-Process incoming cancel messages from CHCS ;09/06/02
+1 ;;7.0;OUTPATIENT PHARMACY;**111,121,146,223,148,249**;DEC 1997;Build 9
+2 ;External reference to ^PSSLOCK supported by DBIA 2789
+3 ;
ENDC ;
+1 ;Process exceptions
+2 NEW DA,PSOEXINP,PSOHLINR,PSOHLSTP,PSOHLSTR,PSOHLPL,PSOHLCM,PSOCANRC,PSOCANRN,PSOHUIOR
+3 SET (PSOHBDS,PSOEXXQ)=0
+4 IF PSOHDFOR
SET PSOEXMS="Invalid message structure."
DO NAK^PSOHLEXC
QUIT
+5 FOR PSOHMSG="MSH","PID","ORC"
if PSOEXXQ
QUIT
IF '$DATA(PSOHLMIS(PSOHMSG))
SET PSOEXMS="Missing "_PSOHMSG_" segment."
SET PSOHBDS=1
DO NAK^PSOHLEXC
+6 IF $GET(PSOEXXQ)
QUIT
+7 IF $GET(HL("SAN"))=""
SET PSOEXMS="Missing sending application name."
DO NAK^PSOHLEXC
QUIT
+8 SET PSOHY("EXAPP")=HL("SAN")
+9 IF '$GET(PSOHY("PAT"))!('$DATA(^DPT(+$GET(PSOHY("PAT")),0)))
SET PSOEXMS="Invalid patient entry."
DO NAK^PSOHLEXC
QUIT
+10 IF $GET(PSOHY("CHNUM"))=""
SET PSOEXMS="Missing CHCS Placer Order Number."
DO NAK^PSOHLEXC
QUIT
+11 DO CAN^PSOHLEXC
+12 IF $GET(PSOEXXQ)
QUIT
+13 SET (PSOEXINP,PSOHLINR)=0
+14 SET PSOEXINP=$ORDER(^PS(52.41,"C",PSOHY("CHNUM"),PSOHY("EXAPP"),0))
IF PSOEXINP
DO PEND
QUIT
+15 SET PSOHLINR=$ORDER(^PSRX("D",PSOHY("CHNUM"),PSOHY("EXAPP"),0))
IF PSOHLINR
DO RX
QUIT
+16 SET PSOEXMS="Unable to find order in Pharmacy."
DO NAK^PSOHLEXC
+17 QUIT
PEND ;Process a DC message on a Pending order
+1 IF PSOHY("PAT")'=$PIECE($GET(^PS(52.41,PSOEXINP,0)),"^",2)
SET PSOEXMS="Patient mismatch in Pending order."
DO NAK^PSOHLEXC
QUIT
+2 KILL PSOMSG
DO PSOL^PSSLOCK(+PSOEXINP_"S")
IF '$GET(PSOMSG)
SET PSOEXMS="Pending order is being edited by another user."
DO NAK^PSOHLEXC
KILL PSOMSG
QUIT
+3 KILL PSOMSG
+4 SET PSOHLSTP=$PIECE($GET(^PS(52.41,PSOEXINP,0)),"^",3)
+5 IF PSOHLSTP'="NW"
Begin DoDot:1
+6 SET PSOEXMS="Unable to cancel Pending order, status is "_$SELECT(PSOHLSTP="HD":"HOLD",PSOHLSTP="RNW":"RENEW",PSOHLSTP="DE":"DISCONTINUE (EDIT)",PSOHLSTP="DC":"DISCONTINUE",PSOHLSTP="RF":"REFILL REQUEST",1:"UNKNOWN")_"."
End DoDot:1
DO NAK^PSOHLEXC
QUIT
+7 SET $PIECE(^PS(52.41,PSOEXINP,0),"^",3)="DC"
+8 SET PSOHLPL=$PIECE(^PS(52.41,PSOEXINP,0),"^")
+9 KILL ^PS(52.41,"AOR",+$PIECE($GET(^PS(52.41,PSOEXINP,0)),"^",2),+$PIECE($GET(^PS(52.41,PSOEXINP,"INI")),"^"),PSOEXINP)
+10 SET PSOHLCM="Discontinued by Provider."
+11 SET $PIECE(^PS(52.41,PSOEXINP,4),"^")=PSOHLCM
+12 DO PVSET
+13 SET PSOHUIOR=1
+14 IF PSOHLPL
DO EN^PSOHLSN(PSOHLPL,"OC",PSOHLCM,"")
+15 DO PSOUL^PSSLOCK(+PSOEXINP_"S")
+16 DO ACK^PSOHLEXC
+17 KILL PSOHUIOR
+18 QUIT
RX ;Process a DC message on a prescription
+1 NEW PSOSUSD,PSOIFN,PSORFDT,PSOHTEST,PSOHPDA,CMOP,ACOM,PSOARECX,PSODFN
+2 SET PSOARECX=0
+3 IF PSOHY("PAT")'=$PIECE($GET(^PSRX(PSOHLINR,0)),"^",2)
SET PSOEXMS="Patient mismatch in prescription."
DO NAK^PSOHLEXC
QUIT
+4 SET PSODFN=$PIECE($GET(^PSRX(PSOHLINR,0)),"^",2)
+5 KILL PSOMSG
DO PSOL^PSSLOCK(PSOHLINR)
IF '$GET(PSOMSG)
SET PSOEXMS="Prescription is being edited by another user."
DO NAK^PSOHLEXC
KILL PSOMSG
QUIT
+6 KILL PSOMSG
+7 SET PSOHLSTR=$PIECE($GET(^PSRX(PSOHLINR,"STA")),"^")
+8 IF PSOHLSTR>11
IF PSOHLSTR<16
Begin DoDot:1
+9 SET PSOEXMS="Unable to cancel prescription, status is "_$SELECT(PSOHLSTR=12:"DISCONTINUED",PSOHLSTR=13:"DELETED",PSOHLSTR=14:"DISCONTINUED BY PROVIDER",1:"DISCONTINUED (EDIT)")_"."
End DoDot:1
DO NAK^PSOHLEXC
QUIT
+10 SET (PSOHLCM,ACOM)="Discontinued by Provider."
+11 IF PSOHLSTR=3!(PSOHLSTR=16)
Begin DoDot:1
+12 SET (PSOHLCM,ACOM)="Discontinued by Provider while on hold."
if $PIECE($GET(^PSRX(PSOHLINR,"H")),"^")
KILL ^PSRX("AH",$PIECE($GET(^PSRX(PSOHLINR,"H")),"^"),PSOHLINR)
SET ^PSRX(PSOHLINR,"H")=""
+13 IF $PIECE(^PSRX(PSOHLINR,0),"^",13)
IF '$ORDER(^PSRX(PSOHLINR,1,0))
SET DIE=52
SET DR="22///"_$EXTRACT($PIECE(^PSRX(PSOHLINR,0),"^",13),1,7)
SET DA=PSOHLINR
DO ^DIE
KILL DIE,DA,DR
QUIT
+14 SET (PSOIFN,PSOSUSD)=0
SET PSORFDT=""
FOR
SET PSOIFN=$ORDER(^PSRX(PSOHLINR,1,PSOIFN))
if 'PSOIFN
QUIT
SET PSOSUSD=PSOIFN
SET PSORFDT=$PIECE($GET(^PSRX(PSOHLINR,1,PSOIFN,0)),"^")
+15 IF $GET(PSORFDT)=""!('$GET(PSOSUSD))
QUIT
+16 IF '$PIECE($GET(^PSRX(PSOHLINR,1,PSOSUSD,0)),"^",18)
SET PSOHTEST=0
Begin DoDot:2
+17 FOR PSOHPDA=0:0
SET PSOHPDA=$ORDER(^PSRX(PSOHLINR,"L",PSOHPDA))
if 'PSOHPDA
QUIT
IF $PIECE($GET(^PSRX(PSOHLINR,"L",PSOHPDA,0)),"^",2)=PSOSUSD
SET PSOHTEST=1
+18 KILL CMOP
SET DA=PSOHLINR
DO ^PSOCMOPA
IF $GET(CMOP(CMOP("L")))=""
IF $GET(CMOP("S"))'="L"
QUIT
+19 SET PSOHTEST=1
End DoDot:2
IF 'PSOHTEST
KILL ^PSRX(PSOHLINR,1,PSOSUSD),^PSRX("AD",PSORFDT,PSOHLINR,PSOSUSD),^PSRX(PSOHLINR,1,"B",PSORFDT,PSOSUSD),PSOIFN,PSOSUSD,PSORFDT
End DoDot:1
+20 DO SUS
+21 IF '$GET(PSOARECX)
DO ACTL
+22 SET $PIECE(^PSRX(PSOHLINR,"STA"),"^")=14
SET $PIECE(^PSRX(PSOHLINR,3),"^",5)=DT
+23 DO CAN^PSOTPCAN(PSOHLINR)
DO REVERSE^PSOBPSU1(PSOHLINR,,"DC",7)
+24 IF $ORDER(^PS(52.41,"ARF",PSOHLINR,0))
IF '$ORDER(^PS(52.41,"APSOD",PSODFN,0))
SET DA=$ORDER(^PS(52.41,"ARF",PSOHLINR,0))
SET DIK="^PS(52.41,"
DO ^DIK
KILL DIK
+25 DO PVSET
+26 SET PSOHUIOR=1
+27 DO EN^PSOHLSN1(PSOHLINR,"OD","","Discontinued by Provider","")
+28 KILL PSOHUIOR
+29 IF $GET(^PS(52.4,PSOHLINR,0))]""
SET DA=PSOHLINR
SET DIK="^PS(52.4,"
DO ^DIK
KILL DIK
+30 DO PSOUL^PSSLOCK(PSOHLINR)
+31 DO ACK^PSOHLEXC
+32 QUIT
SUS NEW RXDA,SUSDA,IFN,PSORFDEL,SUSD,RF,NODE
+1 SET RXDA=PSOHLINR
SET (DA,SUSDA)=$ORDER(^PS(52.5,"B",PSOHLINR,0))
if DA
Begin DoDot:1
+2 SET SUSD=$PIECE($GET(^PS(52.5,DA,0)),"^",2)
+3 if +$GET(^PS(52.5,DA,"P"))'=1
SET (PSOHLCM,ACOM)="Discontinued by Provider while suspended."
+4 IF $ORDER(^PSRX(PSOHLINR,1,0))
SET PSOARECX=1
DO ACTL
SET DA=PSOHLINR
if '$GET(^PS(52.5,+SUSDA,"P"))
DO REF^PSOCAN2
+5 IF $PIECE($GET(^PS(52.5,+SUSDA,0)),"^",2)
IF $PIECE($GET(^(0)),"^",3)
SET DA=SUSDA
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
End DoDot:1
+6 QUIT
ACTL ;Add Activity log
+1 NEW PSORXREF,REA,PSOACNT,PSOSIBB,PSORFH,PSORFCNT
+2 SET PSORXREF=0
SET PSODFN=+$PIECE(^PSRX(PSOHLINR,0),"^",2)
Begin DoDot:1
+3 SET PSOACNT=0
FOR PSOSUBB=0:0
SET PSOSUBB=$ORDER(^PSRX(PSOHLINR,"A",PSOSUBB))
if 'PSOSUBB
QUIT
SET PSOACNT=PSOSUBB
+4 SET PSORFCNT=0
FOR PSORFH=0:0
SET PSORFH=$ORDER(^PSRX(PSOHLINR,1,PSORFH))
if 'PSORFH
QUIT
SET PSORFCNT=PSORFH
if PSORFH>5
SET PSORFCNT=PSORFH+1
+5 DO NOW^%DTC
SET ^PSRX(PSOHLINR,"A",0)="^52.3DA^"_(PSOACNT+1)_"^"_(PSOACNT+1)
SET ^PSRX(PSOHLINR,"A",PSOACNT+1,0)=%_"^C^"_$GET(PSOHY("PROV"))_"^"_PSORFCNT_"^"_$GET(PSOHLCM)
+6 SET REA="C"
SET DA=PSOHLINR
NEW EXP,PCD,IFN
DO EXP^PSOHELP1
End DoDot:1
+7 QUIT
PVSET ;
+1 NEW DIC,X,Y,USER1
+2 DO USER^PSOORFI2(PSOHY("PROV"))
+3 SET PSOCANRC=PSOHY("PROV")
SET PSOCANRN=USER1
+4 QUIT
