source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLDC.m@ 1397

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