Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOHLDC

PSOHLDC.m

Go to the documentation of this file.
  1. 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
  1. ;External reference to ^PSSLOCK supported by DBIA 2789
  1. ;
  1. ENDC ;
  1. ;Process exceptions
  1. N DA,PSOEXINP,PSOHLINR,PSOHLSTP,PSOHLSTR,PSOHLPL,PSOHLCM,PSOCANRC,PSOCANRN,PSOHUIOR
  1. S (PSOHBDS,PSOEXXQ)=0
  1. I PSOHDFOR S PSOEXMS="Invalid message structure." D NAK^PSOHLEXC Q
  1. F PSOHMSG="MSH","PID","ORC" Q:PSOEXXQ I '$D(PSOHLMIS(PSOHMSG)) S PSOEXMS="Missing "_PSOHMSG_" segment." S PSOHBDS=1 D NAK^PSOHLEXC
  1. I $G(PSOEXXQ) Q
  1. I $G(HL("SAN"))="" S PSOEXMS="Missing sending application name." D NAK^PSOHLEXC Q
  1. S PSOHY("EXAPP")=HL("SAN")
  1. I '$G(PSOHY("PAT"))!('$D(^DPT(+$G(PSOHY("PAT")),0))) S PSOEXMS="Invalid patient entry." D NAK^PSOHLEXC Q
  1. I $G(PSOHY("CHNUM"))="" S PSOEXMS="Missing CHCS Placer Order Number." D NAK^PSOHLEXC Q
  1. D CAN^PSOHLEXC
  1. I $G(PSOEXXQ) Q
  1. S (PSOEXINP,PSOHLINR)=0
  1. S PSOEXINP=$O(^PS(52.41,"C",PSOHY("CHNUM"),PSOHY("EXAPP"),0)) I PSOEXINP D PEND Q
  1. S PSOHLINR=$O(^PSRX("D",PSOHY("CHNUM"),PSOHY("EXAPP"),0)) I PSOHLINR D RX Q
  1. S PSOEXMS="Unable to find order in Pharmacy." D NAK^PSOHLEXC
  1. Q
  1. PEND ;Process a DC message on a Pending order
  1. I PSOHY("PAT")'=$P($G(^PS(52.41,PSOEXINP,0)),"^",2) S PSOEXMS="Patient mismatch in Pending order." D NAK^PSOHLEXC Q
  1. 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
  1. K PSOMSG
  1. S PSOHLSTP=$P($G(^PS(52.41,PSOEXINP,0)),"^",3)
  1. I PSOHLSTP'="NW" D D NAK^PSOHLEXC Q
  1. .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")_"."
  1. S $P(^PS(52.41,PSOEXINP,0),"^",3)="DC"
  1. S PSOHLPL=$P(^PS(52.41,PSOEXINP,0),"^")
  1. K ^PS(52.41,"AOR",+$P($G(^PS(52.41,PSOEXINP,0)),"^",2),+$P($G(^PS(52.41,PSOEXINP,"INI")),"^"),PSOEXINP)
  1. S PSOHLCM="Discontinued by Provider."
  1. S $P(^PS(52.41,PSOEXINP,4),"^")=PSOHLCM
  1. D PVSET
  1. S PSOHUIOR=1
  1. I PSOHLPL D EN^PSOHLSN(PSOHLPL,"OC",PSOHLCM,"")
  1. D PSOUL^PSSLOCK(+PSOEXINP_"S")
  1. D ACK^PSOHLEXC
  1. K PSOHUIOR
  1. Q
  1. RX ;Process a DC message on a prescription
  1. N PSOSUSD,PSOIFN,PSORFDT,PSOHTEST,PSOHPDA,CMOP,ACOM,PSOARECX,PSODFN
  1. S PSOARECX=0
  1. I PSOHY("PAT")'=$P($G(^PSRX(PSOHLINR,0)),"^",2) S PSOEXMS="Patient mismatch in prescription." D NAK^PSOHLEXC Q
  1. S PSODFN=$P($G(^PSRX(PSOHLINR,0)),"^",2)
  1. K PSOMSG D PSOL^PSSLOCK(PSOHLINR) I '$G(PSOMSG) S PSOEXMS="Prescription is being edited by another user." D NAK^PSOHLEXC K PSOMSG Q
  1. K PSOMSG
  1. S PSOHLSTR=$P($G(^PSRX(PSOHLINR,"STA")),"^")
  1. I PSOHLSTR>11,PSOHLSTR<16 D D NAK^PSOHLEXC Q
  1. .S PSOEXMS="Unable to cancel prescription, status is "_$S(PSOHLSTR=12:"DISCONTINUED",PSOHLSTR=13:"DELETED",PSOHLSTR=14:"DISCONTINUED BY PROVIDER",1:"DISCONTINUED (EDIT)")_"."
  1. S (PSOHLCM,ACOM)="Discontinued by Provider."
  1. I PSOHLSTR=3!(PSOHLSTR=16) D
  1. .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")=""
  1. .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
  1. .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)),"^")
  1. .I $G(PSORFDT)=""!('$G(PSOSUSD)) Q
  1. .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
  1. ..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
  1. ..K CMOP S DA=PSOHLINR D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q
  1. ..S PSOHTEST=1
  1. D SUS
  1. I '$G(PSOARECX) D ACTL
  1. S $P(^PSRX(PSOHLINR,"STA"),"^")=14,$P(^PSRX(PSOHLINR,3),"^",5)=DT
  1. D CAN^PSOTPCAN(PSOHLINR),REVERSE^PSOBPSU1(PSOHLINR,,"DC",7)
  1. 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
  1. D PVSET
  1. S PSOHUIOR=1
  1. D EN^PSOHLSN1(PSOHLINR,"OD","","Discontinued by Provider","")
  1. K PSOHUIOR
  1. I $G(^PS(52.4,PSOHLINR,0))]"" S DA=PSOHLINR,DIK="^PS(52.4," D ^DIK K DIK
  1. D PSOUL^PSSLOCK(PSOHLINR)
  1. D ACK^PSOHLEXC
  1. Q
  1. SUS N RXDA,SUSDA,IFN,PSORFDEL,SUSD,RF,NODE
  1. S RXDA=PSOHLINR,(DA,SUSDA)=$O(^PS(52.5,"B",PSOHLINR,0)) D:DA
  1. .S SUSD=$P($G(^PS(52.5,DA,0)),"^",2)
  1. .S:+$G(^PS(52.5,DA,"P"))'=1 (PSOHLCM,ACOM)="Discontinued by Provider while suspended."
  1. .I $O(^PSRX(PSOHLINR,1,0)) S PSOARECX=1 D ACTL S DA=PSOHLINR D:'$G(^PS(52.5,+SUSDA,"P")) REF^PSOCAN2
  1. .I $P($G(^PS(52.5,+SUSDA,0)),"^",2),$P($G(^(0)),"^",3) S DA=SUSDA,DIK="^PS(52.5," D ^DIK K DIK
  1. Q
  1. ACTL ;Add Activity log
  1. N PSORXREF,REA,PSOACNT,PSOSIBB,PSORFH,PSORFCNT
  1. S PSORXREF=0,PSODFN=+$P(^PSRX(PSOHLINR,0),"^",2) D
  1. .S PSOACNT=0 F PSOSUBB=0:0 S PSOSUBB=$O(^PSRX(PSOHLINR,"A",PSOSUBB)) Q:'PSOSUBB S PSOACNT=PSOSUBB
  1. .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
  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)
  1. .S REA="C" S DA=PSOHLINR N EXP,PCD,IFN D EXP^PSOHELP1
  1. Q
  1. PVSET ;
  1. N DIC,X,Y,USER1
  1. D USER^PSOORFI2(PSOHY("PROV"))
  1. S PSOCANRC=PSOHY("PROV"),PSOCANRN=USER1
  1. Q