- 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 Feb 18, 2025@23:56:09 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