PSOCLO1 ;BHAM ISC/SAB, HEC/hrubovcak - Clozapine Rx lockout logic ;24 Feb 2020 14:00:01
;;7.0;OUTPATIENT PHARMACY;**1,23,37,222,457,574,612,621,613**;DEC 1997;Build 10
; YSCLTST2 - DBIA 4556
;Reference to ^YSCL(603.01 - DBIA 2697
;MH package will authorize dispensing of the Clozapine drugs
K ANQDATA,ANQX,ANQNO,FLG,PSONEW("SAND"),^TMP($J,"PSO"),^TMP($J,"CLOZFLG",DFN)
N %,ANQ,ANQD,ANQJ,ANQRE,CLOZFLG,D,DIR,DIRUT,DTOUT,DUOUT,J,PSCLZREG,PSMSGTXT,PSOYS,PSTYPE,X,Y
; START NCC REMEDIATION
W !!,"Now doing Clozapine Order checks. Please wait...",!
I XQY0["PSO" S PSTYPE=0,PSMSGTXT="prescription" K PSOSAND
I XQY0["PSJ" S PSTYPE=1,PSMSGTXT="order"
;
; PSO*7.0*574 ; set PSODFN if coming from IP OE
I '($G(PSODFN)>0) S:$G(DFN) PSODFN=DFN Q:'($G(PSODFN)>0) ; must have DFN
;Begin: JCH - PSO*7*612
N PSOYSIEN S PSOYSIEN=$$GETREGYS^PSOCLUTL(PSODFN)
S D=$P($G(^YSCL(603.01,+$G(PSOYSIEN),0)),U,3),CLOZPAT=$S(D="M":2,D="B":1,1:0)
;End: JCH - PSO*7*612
I $D(PSONEW),$G(PSONEW("IRXN")) D EXPDT(.PSONEW,.CLOZPT) ; expiration date for new order
I $D(PSORXED),$G(PSORXED("IRXN")) D EXPDT(.PSORXED,.CLOZPT) ; determine expiration date for edited order
S CLOZFLG=0 ; Used to force start/stop dates to four days only
; ^PS(55,D0,SAND)= (#53) CLOZAPINE REGISTRATION NUMBER [1F] ^ (#54) CLOZAPINE STATUS [2S]
S PSCLZREG=$$GET1^DIQ(55,DFN,53),PSCLZREG("status")=$$GET1^DIQ(55,DFN,54,"I")
D LABRSLT^PSOCLOU(DFN,.PSOYS,.CLOZPAT) ; get lab tests
I PSCLZREG=""!(PSCLZREG("status")="D") D D NOREG Q:'CLOZFLG S PSCLZREG=$$GET1^DIQ(55,DFN,53)
. W !!,"*** This patient has no clozapine registration number ***",!
I PSCLZREG?1U6N S ^TMP($J,"CLOZFLG",DFN)=1
;
S PSLAST7="" ; ** NCC REMEDIATION ** 457/RTW
S PSOYS=$$CL^YSCLTST2(DFN)
;
I PSCLZREG("status")="A",PSCLZREG?2U5N,PSOYS("rANC")="",PSOYS("rWBC")="" G OV1
G:+PSOYS<0 END
S CLOZPAT=$P(PSOYS,U,7),CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
G:+PSOYS=0 OV1
I +PSOYS=1 D
.I '$G(CLOZFLG),$G(^TMP($J,"CLOZFLG",DFN)) S CLOZFLG=1 ;Q ; JCH - PSO*7*613 Remove Quit
.D DSP
; Begin: JCH - PSO*7*612 - Kill ^XTMP's if patient has Active NCCC registration and valid labs
I PSOYS("rWBC")>0,PSOYS("rANC")>1499,'$G(CLOZFLG) D:'$G(PSTYPE) GDOSE D Q
.I PSCLZREG("status")="A",PSCLZREG?2U5N K ^XTMP("PSO4D-"_DFN) K ^XTMP("PSJ4D-"_DFN)
; End - PSO*7*612
I $G(ANQRE)'=7,$$OVERRIDE^YSCLTST2(DFN) S ANQRE=7,ANQX=0 W !!,"Permission to dispense clozapine has been authorized by NCCC",!
I $G(CLOZFLG),+PSOYS=1 S ANQRE=8
S X=$S(CLOZPAT=2:84,CLOZPAT=1:42,1:21)
D CL1^YSCLTST2(DFN,X)
;/RBN-RJS Begin modification for override bypass
I $D(^TMP($J,"PSO")) D:'$G(CLOZFLG) DSP D CHECK ;AJF - added check for CLOZFLG PSO*574
I $P(ANQ(1),U,2)>1499,+$G(PSTYPE),'+$G(ANQRE) Q ;/RJS Emergency override
I $P(ANQ(1),U,2)>1499,'$G(PSTYPE),'+$G(ANQRE) D DOSE Q ;/RJS Emergency override
E D OVRD
;/RBN-RJS End modification for override bypass
Q
;
OV1 ;
I $$OVERRIDE^YSCLTST2(DFN) S ANQRE=7,ANQX=0 W !!,"Permission to dispense clozapine has been authorized by NCCC",!
S X=$S(CLOZPAT=2:84,CLOZPAT=1:42,1:21)
D CL1^YSCLTST2(DFN,X)
S:$P(PSOYS,U,6)="" $P(PSOYS,U,6)=DT
I $G(ANQRE)'=7 D DSP,CHECK
I $G(ANQRE)=8!($G(ANQRE)=7) D OVRD Q
; patient is ACTIVE, has no labs, regular registration #
I 'PSOYS("rWBC"),'PSOYS("rANC"),PSCLZREG("status")="A",PSCLZREG?2U5N D Q
. D PKEYCHK Q:$G(ANQX) ; doesn't hold key
. D:PSTYPE=1 MSG10^PSOCLUTL ; inpt
. D:PSTYPE=0 MSG9^PSOCLUTL ; outpt
. S ANQRE=9 D OVRD ; PRESCRIBER APPROVED 4 DAY SUPPLY
;
I PSOYS("rWBC"),PSOYS("rANC")<1000,PSOYS("rANC")>0 D MSG4^PSOCLUTL,MSG3^PSOCLUTL,MH,QU Q
I $D(PSCLZREG),'PSOYS("rWBC"),'PSOYS("rANC") D MSG4^PSOCLUTL,MSG3^PSOCLUTL,MH,QU Q
I PSTYPE=0 D ; outpatient
. I PSOYS("rWBC"),'PSOYS("rANC") D MSG9^PSOCLUTL,PKEYCHK,OVRD Q ; WBC, no ANC
. I PSOYS("rWBC"),'PSOYS("rANC") D MSG9^PSOCLUTL,PKEYCHK,OVRD Q ; No labs
;
I PSTYPE=1 D ; inpatient
. I PSOYS("rWBC"),'PSOYS("rANC") D MSG10^PSOCLUTL,OVRD Q ; WBC, no ANC
. I 'PSOYS("rWBC"),'PSOYS("rANC") D MSG10^PSOCLUTL,PKEYCHK,OVRD Q ; No labs
;
I 'PSOYS("rWBC"),PSOYS("rANC") D MSG1^PSOCLUTL Q ; ANC, no WBC
Q
CHECK ;
S:'$$HASKEY(DUZ) ANQX=0
I $G(ANQRE)'=7,$G(ANQRE)'=8 S ANQRE=$S('PSOYS("rANC"):9,PSOYS("rANC")<1000:9,'PSOYS("rWBC"):9,PSOYS("rANC")<1500:10,PSLAST7["Y":9,1:0)
I '$P(PSOYS,U,6) S $P(PSOYS,U,6)=$$NOW^XLFDT
S (ANQD,ANQD(1))=9999999-$P(PSOYS,U,6)
S ANQ(1)=PSOYS("rWBC")_U_PSOYS("rANC") D
.Q:'$D(^TMP($J,"PSO"))
.F ANQJ=2:1:4 S ANQD=$O(^TMP($J,"PSO",ANQD)) Q:'ANQD S ANQ(ANQJ)=^(ANQD),ANQD(ANQJ)=ANQD
S ANQD=$O(ANQ(""),-1)
I $D(PSCLZREG),PSCLZREG=""!(PSCLZREG?1U6N),PSOYS("rANC")'>1499 D Q ; temporary reg # not enough
. W !,"Emergency overrides for non-registered clozapine patients require",!,"ANC levels greater than or equal to 1500",!
. S ANQX=1
I ANQD<2 W !,"*** No previous results to display ***",! Q
S ANQ=$S($P(ANQ(1),U)!$P(ANQ(1),U,2):ANQD,1:ANQD-1)
W !,"*** Last "_$S(ANQ=4:"Four ",ANQ=3:"Three ",ANQ=2:"Two ",1:"")_"WBC and NEUTROPHILS ABSOLUTE (ANC) results ***",!
W !,$J("WBC ANC",49),!
F ANQJ=ANQD:-1:1 S ANQD=9999999-ANQD(ANQJ)_"0000" D
. I $L($P($G(ANQ(ANQJ)),U))!$L($P($G(ANQ(ANQJ)),U,2)) D
.. W $$FMTE^XLFDT(ANQD,"5Z") W:ANQD["." "@",$E(ANQD,9,10),":",$E(ANQD,11,12)
.. W ?29,"Results: "_$J($P(ANQ(ANQJ),U),4)_" ",$J($P(ANQ(ANQJ),U,2),4),!
Q
;
OVRD ;
Q:$G(ANQX)
N PSREASON
I ANQRE,'$$HASKEY(DUZ) D D QU G EXIT
. S ANQX=1 W !!,"You Are Not Authorized to Override! See Clozapine Manager with PSOLOCKCLOZ key."
;
I $L($G(PSOYS)) D:PSOYS("rANC")<1000 ; severe neutropenia
. W !,"Test ANC labs daily until levels stabilize to ANC greater than or equal to 1000.",!
I ANQRE W !,"Override reason: "_$$OVRDTXT^PSOCLOU(ANQRE),! D
. I ANQRE=7 D Q
.. S PSREASON=$$OVRDTXT^PSOCLOU(ANQRE)
.. D OVPRMPT Q:$G(ANQX)
.. D OVRD2 Q:$G(ANQX)
.. D OVRREA
. I ANQRE=5 D Q
.. N DIR S DIR("A")="ANC levels are Critically low. Do you want to Cancel the order",DIR(0)="Y",DIR("B")="N"
.. D ^DIR I Y=0 D MSG6^PSOCLUTL Q
.. I Y(0)="YES"!($D(DTOUT))!($D(DUOUT))!($D(DIROUT)) S ANQX=1 K Q
. I $G(ANQRE)=8 D Q
.. S ANQX=0 D OVPRMPT Q:$G(ANQX)
.. D OVRD2 Q:$G(ANQX)
.. D OVRREA Q:$G(ANQX)
.. D CRXTMPI(DFN,PSOYS)
. ;/RBN Begin modifications for new special override condition for inpatient
. I ANQRE=9,PSTYPE=0 D Q
.. D OVPRMPT Q:$G(ANQX)
.. N DIR,DIRUT S DIR(0)="S^1:Weather Related Conditions;2:Mail Order Delay;3:Inpatient Going On Leave"
.. S DIR("A")="Prescriber's reason for Special Condition Override " D ^DIR I $D(DIRUT) S ANQX=1 Q
.. S PSREASON=Y(0)_": ",^TMP($J,"CLOZFLG",DFN)=1
.. D OVRD2 Q:$G(ANQX)
.. D OVRREA Q:$G(ANQX)
.. S PSREMARK=PSREASON_PSREMARK
.. D CRXTMP(DFN,PSOYS)
. I ANQRE=9,PSTYPE=1 D Q
.. D OVPRMPT Q:$G(ANQX)
.. S PSREASON="IP Order Override with Outside Lab Results: ",^TMP($J,"CLOZFLG",DFN)=1
.. W !,$P(PSREASON,":"),!
.. D OVRREA Q:$G(ANQX)
.. D OVRD2 Q:$G(ANQX)
.. S PSREMARK=PSREASON_PSREMARK
.. D CRXTMPI(DFN,PSOYS)
. I ANQRE=10 D
.. W !,"Test ANC Results 3x weekly until ANC stabilize to greater than or equal to 1500",!
.. D OVPRMPT Q:$G(ANQX)
.. D OVRD2 Q:$G(ANQX)
.. D OVRREA
;
I $G(ANQX) D EXIT Q
;
S PSPROVID="UNKNOWN"
I $D(ND0) S PSPROVID=$P(ND0,U,2),PSJORN=$P(ND0,U,21),PSJORDER("PSJORN")=PSJORN
I $D(ORO) S PSPROVID=$P(ORO,U,4),PSJORN=$P(ORO,U),PSJORDER("PSJORN")=PSJORN
I '$G(PSPROVID),$G(PSTYPE),$G(PSGOEPR) S PSPROVID=+$G(PSGOEPR)
I $D(DUPRX0) S PSPROVID=$P(DUPRX0,U,4)
S:ANQRE SANQX=0,PSCLPAT=DFN,ANQDATA=DUZ_U_PSPROVID_U_ANQRE_U_PSREMARK_U_PSSPHARM_U_PSCLPAT_U_$G(PSJORN)
;
GDOSE ; ask daily dose
I $G(PSTYPE) Q ; not for inpatient
N IENX,PSOCD,PSRXDOS
D ; retrieve DOSAGE ORDERED fields
. ; get parent IEN for new or edited Rx
. N FLD,IRXNTMP S IENX=$S($G(PSORXED("IRXN")):PSORXED("IRXN"),$G(PSONEW("IRXN")):PSONEW("IRXN"),1:0)
. S PSRXDOS("CLOZDOSE301")=$$GET1^DIQ(52,IENX,301) ; (#301) CLOZAPINE DOSAGE (MG/DAY) [1N]
. S IRXNTMP="1,"_IENX F FLD=.01,1:1:9 S PSRXDOS(FLD)=$$GET1^DIQ(52.0113,IRXNTMP,FLD)
;
DOSE ;
K DIR S DIR(0)="N^12.5:3000:1",DIR("A")="CLOZAPINE dosage (mg/day)? "
I '(PSRXDOS(.01)<12.5),'(PSRXDOS(.01)>900) S DIR("B")=PSRXDOS(.01) ; default only for standard dose
D ^DIR K DIR G EXIT:$D(DIRUT)!$D(DTOUT)
S PSOCD=X
;
I PSOCD#25=0,PSOCD'<12.5,PSOCD<900 G EXIT
I PSOCD#12.5 S DIR(0)="Y",DIR("B")="NO",DIR("A")=PSOCD_" is an unusual dose. Are you sure" D ^DIR K DIR G EXIT:$D(DIRUT) I 'Y G DOSE
I PSOCD>900 S DIR(0)="Y",DIR("A")="Recommended maximum daily dose is 900. Are you sure" D ^DIR K DIR G EXIT:$D(DIRUT) I 'Y G DOSE
;
EXIT ;
K ^TMP($J,"PSO")
S:$D(DIRUT) ANQX=1
I $G(ANQX) W !!,"No "_PSMSGTXT_" entered!" H 2 Q
;
D LABRSLT^PSOCLOU(DFN,.PSOYS,.CLOZPAT) ; if added to files #55 or #603.01 lab results may be available
S (PSONEW("SAND"),PSOSAND)=PSOCD_U_PSOYS("rWBC")_U_($P($P(PSOYS,U,6),"."))_U_PSOYS("rANC")
N NDAYS S NDAYS=$S($G(ANQRE)=9!(PSCLZREG?1U6N):4,CLOZPAT=2:28,CLOZPAT=1:14,1:7)
I $G(PSONEW("DAYS SUPPLY"))>NDAYS D
. S PSONEW("DAYS SUPPLY")=NDAYS,$P(PSONEW("RX0"),U,8)=NDAYS
. ; No DURATION set if 4 DAY SUPPLY
. S:$G(NDAYS)'=4 PSONEW("DURATION",1)=NDAYS
. N PSOIENX S PSOIENX="1,"_$G(PSORXIEN)
. S PSONEW("SCHEDULE",1)=$$GET1^DIQ(52.0113,PSOIENX,7)
. S PSONEW("DOSE ORDERED",1)=$$GET1^DIQ(52.0113,PSOIENX,1)
. D QTYCHK(.PSONEW,NDAYS)
; if Rx edited, then update it
I $D(PSORXED) D EXPDT(.PSORXED,.CLOZPT) ; in case of edits
;
Q
;
OVPRMPT ; ask user to override
N DIR
S DIR("A")="Do you want to override and issue this "_PSMSGTXT,DIR(0)="Y",DIR("B")="N" D ^DIR
I 'Y!($D(DIROUT)!($D(DTOUT))) S ANQX=1
Q
;
PKEYCHK ; does user have PSOLOCKCLOZ key
I '$D(PSGSTAT)!($G(PSGSTAT)="PENDING") D
. Q:$$HASKEY(DUZ) ; has security key
. S ANQX=1 W !,"You Are Not Authorized to Override! See Clozapine Manager with PSOLOCKCLOZ key."
Q
;
MH ;
W !!,"Also make sure that the LAB test, ANC is set up correctly in the"
W !,"Mental Health package using the CLOZAPINE MULTI TEST LINK option.",!
Q
DSP ; subroutine: NCC remediation PSO*7.0*457
I 'PSOYS("rWBC"),'PSOYS("rANC") Q
N DIR,Y S Y=$P($$FMTE^XLFDT($P(PSOYS,U,6)),"@")
W !,"*** Most recent WBC and "_$P(PSOYS,U,5)_" (ANC) results ***"
W !," performed on "_Y_" are: "
W !!," "_$P(PSOYS,U,3)_": "_PSOYS("rWBC")
W !," ANC: "_PSOYS("rANC"),!
S DIR(0)="EA",DIR("A")="Type <Enter> to continue: " D ^DIR W !
;
Q
DIR ;
W !! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DTOUT,DUOUT,DIRUT
Q
;
END ;
D MSG5^PSOCLUTL
QU ; no med prescribed
S ANQX=1 D DIR
Q
;
NOREG ; Register a new/discontinued non-registered cloz patient
;
N %,I,MSG,MSGNUM,NOW,PSCLZREG,PSO1,PSO2,PSO4,PSONAME,PTINFO,STAT,TMP,X,XMSUB,XMTEXT,Y
; Check for authorization key
I '$$HASKEY(DUZ) D Q
. S ANQX=1 W !,"You Are Not Authorized to Override! See Clozapine Manager with PSOLOCKCLOZ key." W:PSTYPE=1 !!,"No order entered!"
;
W !,"Do you want to register this patient with a temporary local"
W !," authorization number in the Clozapine registry? Y/N "
S %=2 D YN^DICN I %'=1 S ANQX=1 W !,"Patient Not Registered",! Q
W !
S (PSO1,TMP("DFN"))=DFN
S PSO2=$$FINDNEXT^PSOCLOU
I PSO2=-1 D S ANQX=1 Q
. W !!,"All emergency registration numbers have been used."
. W !,"Emergency registration may no longer be done at this site",!!
. W !,"Patient Not Registered",!
CONT S TMP("PSO2")=PSO2
S PSONAME=$$GET1^DIQ(2,PSO1,.01)
S PSCLOZ=1,DFN=TMP("DFN")
S PSO2=TMP("PSO2") ; used in NUMBER1^PSOCLUTL
; Check if registration in file #55 failed or was terminated
S PTINFO("surname")=$P(PSONAME,","),PTINFO("firstNm")=$P($P(PSONAME,",",2)," ")
S PTINFO("ssn")=$$GET1^DIQ(2,PSO1,.09),PTINFO("last4")=$E(PTINFO("ssn"),6,9),ANQX=1
D NUMBER1^PSOCLUTL
Q:$G(ANQX)
S PSCLZREG=TMP("PSO2") D ; delete entries in file 603.01 for this patient
. N DA,DIK
. S DIK="^YSCL(603.01,",DA="" F S DA=$O(^YSCL(603.01,"C",DFN,DA)) Q:DA="" D ^DIK
S MSG(1)=PSCLZREG_","_PTINFO("surname")_","_PTINFO("firstNm")_","_PTINFO("last4")
S XMTEXT="MSG(",XMSUB="ADD"
N YSPROD S YSPROD=$$GET1^DIQ(8989.3,1,501,"I") D
. I YSPROD S XMY("G.RUCLDEM@FO-DALLAS.DOMAIN.EXT")="" Q ; production account
. S XMY("G.CLOZAPINE ROLL-UP")="" ; test account
D ^XMD
S DFN=TMP("DFN")
I '$G(XMMG) S MSGNUM=$G(XMZ)
E W !!,"Failed to connect with the NCCC." S PSOFL=1 Q
; use the server logic for sending a message to populate 55 and 603.01
S PSCLOZ=1,^TMP($J,"CLOZFLG",DFN)=1,XMRG=MSG(1),XMFROM=DUZ,XQDATE=$$NOW^XLFDT
D ^YSCLSERV
D XTMPZRO^PSOCLOU
S:PSCLZREG?1U6N $P(^XTMP("PSJ CLOZ",0),U,4)=PSCLZREG ; save only temp registration #
S ^XTMP("PSJ CLOZ",DFN)=DT_U_PSCLZREG_U_"A"
S ^XTMP("PSJ CLOZ","B",PSCLZREG,DFN)=$$FMADD^XLFDT($$NOW^XLFDT,4) ; four days from now
S ^XTMP("PSJ CLOZ","C",DFN,PSCLZREG)=""
S ANQX=0,CLOZFLG=1
D LABRSLT^PSOCLOU(DFN,.PSOYS,.CLOZPAT) ; lab results may now be available
;
QUIT ;
Q
;
OVRD2 ;
S PSSPHARM="" ; clozapine team member IEN
D OVRDTMBR^PSOCLOU
S:'PSSPHARM ANQX=1 ; no team member selected, exit
Q
;
OVRREA ; Override reason when order is NCCC Approved
S ANQX=0
I $G(ANQRE)>6 D
. N DIR,DTOUT,DUOUT,DIRUT,DIROUT
. S DIR(0)="F^5:200"
. S DIR("A")="REASON FOR OVERRIDE Remarks"
. I $G(ANQRE)=9 S DIR("A")="Remarks: "_$P(PSREASON,":")
. S DIR("?")="Response is 5 to 200 characters."
. D ^DIR
. I $G(DTOUT)!$G(DUOUT)!$G(DIRUT)!$G(DIROUT) S ANQX=1 Q
. S PSREMARK=Y
Q
;
CHK4REG(PSCLDFN) ; See if patient already has a clozapine registration number
N PSCLRSLT
S PSCLRSLT=$O(^XTMP("PSJ CLOZ","C",PSCLDFN,""))
Q PSCLRSLT
;
CHK4DFN(PSCLRGNO) ; See if this Clozapine registration is assigned
N PSCLRSLT
S PSCLRSLT=$O(^XTMP("PSJ CLOZ","B",PSCLRGNO,""))
Q PSCLRSLT
;
CHK4EXP(PSCLRGNO,PSCLDFN) ; Check for registration expiration
; returns zero if expired, 1 if not
N PSCLRSLT,PSCLZDAT
S PSCLRSLT=1
I $D(^XTMP("PSJ CLOZ","B",PSCLRGNO,PSCLDFN)) D
. S PSCLZDAT=$G(^XTMP("PSJ CLOZ","B",PSCLRGNO,PSCLDFN)) Q:'(DT>PSCLZDAT) ; not expired
. S PSCLRSLT=0 S:PSCLZDAT>0 $P(^XTMP("PSJ CLOZ",PSCLDFN),U,3)="D"
;
Q PSCLRSLT
;
CRXTMP(DFN,PSOYS) ; create XTMP entry for 4 day supply tracking
I $G(DFN) D CRXTMP^PSOCLUTL(DFN,PSOYS)
Q
CRXTMPI(DFN,PSOYS) ; create XTMP entry for 4 day supply tracking
I $G(DFN) D CRXTMPI^PSOCLUTL(DFN,PSOYS)
Q
;
HASKEY(USRNUM) ; Boolean function, does USRNUM hold the PSOLOCKCLOZ security key?
I '$G(USRNUM)>0 S USRNUM=DUZ ; default to current user
Q $S($D(^XUSEC("PSOLOCKCLOZ",USRNUM)):1,1:0)
;
EXPDT(PSORXARY,CLOZPT) ; PSORXARY,CLOZPAT passed by ref., determine expiration date (for Clozapine only)
; PSORXARY can be a new Rx (PSONEW) or an edited Rx (PSORXED and PSODIR)
Q:'($G(PSORXARY("IRXN"))>0) ; must have IEN
; Check for updates to DAYS SUPPLY, ISSUE DATE and QUANTITY
N D,DYS2EXPR,PSRXFMDT,PSCLUPDT,NUMREFS
S PSCLUPDT("change")=0
S:$G(PSORXARY("DAYS SUPPLY")) PSCLUPDT("change")=1
S:$G(PSORXARY("FLD",1)) PSCLUPDT("change")=1
S:$G(PSORXARY("QTY")) PSCLUPDT("change")=1
I $D(PSORXARY("N# REF")) D
. S NUMREFS=+$G(PSORXARY("N# REF"))
E D
. S NUMREFS=+$P($G(PSORXARY("RX0")),U,9)
Q:'PSCLUPDT("change") ; no changes, exit
S DYS2EXPR=0 ; days to expire
S PSRXFMDT(1)=0 ; field #1
D ; determine ISSUE DATE
. S PSRXFMDT(1)=$G(PSORXARY("FLD",1)) ; field may have been edited
. Q:PSRXFMDT(1)?7N ; date found
. S PSRXFMDT(1)=$$GET1^DIQ(52,PSORXARY("IRXN")_",",1,"I") ; (#1) ISSUE DATE [13D]
. Q:PSRXFMDT(1)
. S PSRXFMDT(1)=DT ; last resort
;
D ; determine days to expire
. S D=$G(PSORXARY("DAYS SUPPLY")) S:D>0 DYS2EXPR=D*(NUMREFS+1)
. I D,$G(PSORXARY("DAYS SUPPLY OLD")) S PSCLUPDT(8)=PSORXARY("DAYS SUPPLY")
. Q:DYS2EXPR
. S D=$P($G(PSORXARY("RX0")),U,8) I D>0 S DYS2EXPR=D*(NUMREFS+1) Q
. S DYS2EXPR=$S(CLOZPAT=2:28,CLOZPAT=1:14,1:7) ; default
; value for FM call
S PSRXFMDT("expires")=$$FMADD^XLFDT(PSRXFMDT(1),DYS2EXPR)
S PSCLUPDT(26)=PSRXFMDT("expires") ; (#26) EXPIRATION DATE [6D]
S PSORXARY("CLOZ EDIT")=PSCLUPDT(26)
I $G(PSORXARY("DAYS SUPPLY")) D
. D QTYCHK(.PSORXARY,PSORXARY("DAYS SUPPLY"))
. ; only if quantity changed
. I $G(PSORXARY("QTY")) S PSCLUPDT(7)=PSORXARY("QTY") ; (#7) QTY [7N]
;
; update PSORXARY("FLD") nodes to include any edits
; QTY (#7), DAYS SUPPLY (#8), EXPIRATION DATE (#26)
F D=7,8,26 I $G(PSCLUPDT(D)) S PSORXARY("FLD",D)=PSCLUPDT(D)
I $G(PSCLUPDT(8)) S $P(PSORXARY("RX0"),U,8)=PSCLUPDT(8) ; (#8) DAYS SUPPLY [8N]
I $G(PSCLUPDT(26)) S $P(PSORXARY("RX2"),U,6)=PSCLUPDT(26) ; (#26) EXPIRATION DATE [6D]
;
Q
;
QTYCHK(PSORXARY,NUMDAYS) ; check/adjust quantity, PSORXARY passed by ref., NUMDAYS is # of days
Q:'($G(NUMDAYS)>0) ; required
D QTYCHK^PSOCLUTL(.PSORXARY,NUMDAYS)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCLO1 16924 printed Sep 23, 2025@20:01:41 Page 2
PSOCLO1 ;BHAM ISC/SAB, HEC/hrubovcak - Clozapine Rx lockout logic ;24 Feb 2020 14:00:01
+1 ;;7.0;OUTPATIENT PHARMACY;**1,23,37,222,457,574,612,621,613**;DEC 1997;Build 10
+2 ; YSCLTST2 - DBIA 4556
+3 ;Reference to ^YSCL(603.01 - DBIA 2697
+4 ;MH package will authorize dispensing of the Clozapine drugs
+5 KILL ANQDATA,ANQX,ANQNO,FLG,PSONEW("SAND"),^TMP($JOB,"PSO"),^TMP($JOB,"CLOZFLG",DFN)
+6 NEW %,ANQ,ANQD,ANQJ,ANQRE,CLOZFLG,D,DIR,DIRUT,DTOUT,DUOUT,J,PSCLZREG,PSMSGTXT,PSOYS,PSTYPE,X,Y
+7 ; START NCC REMEDIATION
+8 WRITE !!,"Now doing Clozapine Order checks. Please wait...",!
+9 IF XQY0["PSO"
SET PSTYPE=0
SET PSMSGTXT="prescription"
KILL PSOSAND
+10 IF XQY0["PSJ"
SET PSTYPE=1
SET PSMSGTXT="order"
+11 ;
+12 ; PSO*7.0*574 ; set PSODFN if coming from IP OE
+13 ; must have DFN
IF '($GET(PSODFN)>0)
if $GET(DFN)
SET PSODFN=DFN
if '($GET(PSODFN)>0)
QUIT
+14 ;Begin: JCH - PSO*7*612
+15 NEW PSOYSIEN
SET PSOYSIEN=$$GETREGYS^PSOCLUTL(PSODFN)
+16 SET D=$PIECE($GET(^YSCL(603.01,+$GET(PSOYSIEN),0)),U,3)
SET CLOZPAT=$SELECT(D="M":2,D="B":1,1:0)
+17 ;End: JCH - PSO*7*612
+18 ; expiration date for new order
IF $DATA(PSONEW)
IF $GET(PSONEW("IRXN"))
DO EXPDT(.PSONEW,.CLOZPT)
+19 ; determine expiration date for edited order
IF $DATA(PSORXED)
IF $GET(PSORXED("IRXN"))
DO EXPDT(.PSORXED,.CLOZPT)
+20 ; Used to force start/stop dates to four days only
SET CLOZFLG=0
+21 ; ^PS(55,D0,SAND)= (#53) CLOZAPINE REGISTRATION NUMBER [1F] ^ (#54) CLOZAPINE STATUS [2S]
+22 SET PSCLZREG=$$GET1^DIQ(55,DFN,53)
SET PSCLZREG("status")=$$GET1^DIQ(55,DFN,54,"I")
+23 ; get lab tests
DO LABRSLT^PSOCLOU(DFN,.PSOYS,.CLOZPAT)
+24 IF PSCLZREG=""!(PSCLZREG("status")="D")
Begin DoDot:1
+25 WRITE !!,"*** This patient has no clozapine registration number ***",!
End DoDot:1
DO NOREG
if 'CLOZFLG
QUIT
SET PSCLZREG=$$GET1^DIQ(55,DFN,53)
+26 IF PSCLZREG?1U6N
SET ^TMP($JOB,"CLOZFLG",DFN)=1
+27 ;
+28 ; ** NCC REMEDIATION ** 457/RTW
SET PSLAST7=""
+29 SET PSOYS=$$CL^YSCLTST2(DFN)
+30 ;
+31 IF PSCLZREG("status")="A"
IF PSCLZREG?2U5N
IF PSOYS("rANC")=""
IF PSOYS("rWBC")=""
GOTO OV1
+32 if +PSOYS<0
GOTO END
+33 SET CLOZPAT=$PIECE(PSOYS,U,7)
SET CLOZPAT=$SELECT(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
+34 if +PSOYS=0
GOTO OV1
+35 IF +PSOYS=1
Begin DoDot:1
+36 ;Q ; JCH - PSO*7*613 Remove Quit
IF '$GET(CLOZFLG)
IF $GET(^TMP($JOB,"CLOZFLG",DFN))
SET CLOZFLG=1
+37 DO DSP
End DoDot:1
+38 ; Begin: JCH - PSO*7*612 - Kill ^XTMP's if patient has Active NCCC registration and valid labs
+39 IF PSOYS("rWBC")>0
IF PSOYS("rANC")>1499
IF '$GET(CLOZFLG)
if '$GET(PSTYPE)
DO GDOSE
Begin DoDot:1
+40 IF PSCLZREG("status")="A"
IF PSCLZREG?2U5N
KILL ^XTMP("PSO4D-"_DFN)
KILL ^XTMP("PSJ4D-"_DFN)
End DoDot:1
QUIT
+41 ; End - PSO*7*612
+42 IF $GET(ANQRE)'=7
IF $$OVERRIDE^YSCLTST2(DFN)
SET ANQRE=7
SET ANQX=0
WRITE !!,"Permission to dispense clozapine has been authorized by NCCC",!
+43 IF $GET(CLOZFLG)
IF +PSOYS=1
SET ANQRE=8
+44 SET X=$SELECT(CLOZPAT=2:84,CLOZPAT=1:42,1:21)
+45 DO CL1^YSCLTST2(DFN,X)
+46 ;/RBN-RJS Begin modification for override bypass
+47 ;AJF - added check for CLOZFLG PSO*574
IF $DATA(^TMP($JOB,"PSO"))
if '$GET(CLOZFLG)
DO DSP
DO CHECK
+48 ;/RJS Emergency override
IF $PIECE(ANQ(1),U,2)>1499
IF +$GET(PSTYPE)
IF '+$GET(ANQRE)
QUIT
+49 ;/RJS Emergency override
IF $PIECE(ANQ(1),U,2)>1499
IF '$GET(PSTYPE)
IF '+$GET(ANQRE)
DO DOSE
QUIT
+50 IF '$TEST
DO OVRD
+51 ;/RBN-RJS End modification for override bypass
+52 QUIT
+53 ;
OV1 ;
+1 IF $$OVERRIDE^YSCLTST2(DFN)
SET ANQRE=7
SET ANQX=0
WRITE !!,"Permission to dispense clozapine has been authorized by NCCC",!
+2 SET X=$SELECT(CLOZPAT=2:84,CLOZPAT=1:42,1:21)
+3 DO CL1^YSCLTST2(DFN,X)
+4 if $PIECE(PSOYS,U,6)=""
SET $PIECE(PSOYS,U,6)=DT
+5 IF $GET(ANQRE)'=7
DO DSP
DO CHECK
+6 IF $GET(ANQRE)=8!($GET(ANQRE)=7)
DO OVRD
QUIT
+7 ; patient is ACTIVE, has no labs, regular registration #
+8 IF 'PSOYS("rWBC")
IF 'PSOYS("rANC")
IF PSCLZREG("status")="A"
IF PSCLZREG?2U5N
Begin DoDot:1
+9 ; doesn't hold key
DO PKEYCHK
if $GET(ANQX)
QUIT
+10 ; inpt
if PSTYPE=1
DO MSG10^PSOCLUTL
+11 ; outpt
if PSTYPE=0
DO MSG9^PSOCLUTL
+12 ; PRESCRIBER APPROVED 4 DAY SUPPLY
SET ANQRE=9
DO OVRD
End DoDot:1
QUIT
+13 ;
+14 IF PSOYS("rWBC")
IF PSOYS("rANC")<1000
IF PSOYS("rANC")>0
DO MSG4^PSOCLUTL
DO MSG3^PSOCLUTL
DO MH
DO QU
QUIT
+15 IF $DATA(PSCLZREG)
IF 'PSOYS("rWBC")
IF 'PSOYS("rANC")
DO MSG4^PSOCLUTL
DO MSG3^PSOCLUTL
DO MH
DO QU
QUIT
+16 ; outpatient
IF PSTYPE=0
Begin DoDot:1
+17 ; WBC, no ANC
IF PSOYS("rWBC")
IF 'PSOYS("rANC")
DO MSG9^PSOCLUTL
DO PKEYCHK
DO OVRD
QUIT
+18 ; No labs
IF PSOYS("rWBC")
IF 'PSOYS("rANC")
DO MSG9^PSOCLUTL
DO PKEYCHK
DO OVRD
QUIT
End DoDot:1
+19 ;
+20 ; inpatient
IF PSTYPE=1
Begin DoDot:1
+21 ; WBC, no ANC
IF PSOYS("rWBC")
IF 'PSOYS("rANC")
DO MSG10^PSOCLUTL
DO OVRD
QUIT
+22 ; No labs
IF 'PSOYS("rWBC")
IF 'PSOYS("rANC")
DO MSG10^PSOCLUTL
DO PKEYCHK
DO OVRD
QUIT
End DoDot:1
+23 ;
+24 ; ANC, no WBC
IF 'PSOYS("rWBC")
IF PSOYS("rANC")
DO MSG1^PSOCLUTL
QUIT
+25 QUIT
CHECK ;
+1 if '$$HASKEY(DUZ)
SET ANQX=0
+2 IF $GET(ANQRE)'=7
IF $GET(ANQRE)'=8
SET ANQRE=$SELECT('PSOYS("rANC"):9,PSOYS("rANC")<1000:9,'PSOYS("rWBC"):9,PSOYS("rANC")<1500:10,PSLAST7["Y":9,1:0)
+3 IF '$PIECE(PSOYS,U,6)
SET $PIECE(PSOYS,U,6)=$$NOW^XLFDT
+4 SET (ANQD,ANQD(1))=9999999-$PIECE(PSOYS,U,6)
+5 SET ANQ(1)=PSOYS("rWBC")_U_PSOYS("rANC")
Begin DoDot:1
+6 if '$DATA(^TMP($JOB,"PSO"))
QUIT
+7 FOR ANQJ=2:1:4
SET ANQD=$ORDER(^TMP($JOB,"PSO",ANQD))
if 'ANQD
QUIT
SET ANQ(ANQJ)=^(ANQD)
SET ANQD(ANQJ)=ANQD
End DoDot:1
+8 SET ANQD=$ORDER(ANQ(""),-1)
+9 ; temporary reg # not enough
IF $DATA(PSCLZREG)
IF PSCLZREG=""!(PSCLZREG?1U6N)
IF PSOYS("rANC")'>1499
Begin DoDot:1
+10 WRITE !,"Emergency overrides for non-registered clozapine patients require",!,"ANC levels greater than or equal to 1500",!
+11 SET ANQX=1
End DoDot:1
QUIT
+12 IF ANQD<2
WRITE !,"*** No previous results to display ***",!
QUIT
+13 SET ANQ=$SELECT($PIECE(ANQ(1),U)!$PIECE(ANQ(1),U,2):ANQD,1:ANQD-1)
+14 WRITE !,"*** Last "_$SELECT(ANQ=4:"Four ",ANQ=3:"Three ",ANQ=2:"Two ",1:"")_"WBC and NEUTROPHILS ABSOLUTE (ANC) results ***",!
+15 WRITE !,$JUSTIFY("WBC ANC",49),!
+16 FOR ANQJ=ANQD:-1:1
SET ANQD=9999999-ANQD(ANQJ)_"0000"
Begin DoDot:1
+17 IF $LENGTH($PIECE($GET(ANQ(ANQJ)),U))!$LENGTH($PIECE($GET(ANQ(ANQJ)),U,2))
Begin DoDot:2
+18 WRITE $$FMTE^XLFDT(ANQD,"5Z")
if ANQD["."
WRITE "@",$EXTRACT(ANQD,9,10),":",$EXTRACT(ANQD,11,12)
+19 WRITE ?29,"Results: "_$JUSTIFY($PIECE(ANQ(ANQJ),U),4)_" ",$JUSTIFY($PIECE(ANQ(ANQJ),U,2),4),!
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
OVRD ;
+1 if $GET(ANQX)
QUIT
+2 NEW PSREASON
+3 IF ANQRE
IF '$$HASKEY(DUZ)
Begin DoDot:1
+4 SET ANQX=1
WRITE !!,"You Are Not Authorized to Override! See Clozapine Manager with PSOLOCKCLOZ key."
End DoDot:1
DO QU
GOTO EXIT
+5 ;
+6 ; severe neutropenia
IF $LENGTH($GET(PSOYS))
if PSOYS("rANC")<1000
Begin DoDot:1
+7 WRITE !,"Test ANC labs daily until levels stabilize to ANC greater than or equal to 1000.",!
End DoDot:1
+8 IF ANQRE
WRITE !,"Override reason: "_$$OVRDTXT^PSOCLOU(ANQRE),!
Begin DoDot:1
+9 IF ANQRE=7
Begin DoDot:2
+10 SET PSREASON=$$OVRDTXT^PSOCLOU(ANQRE)
+11 DO OVPRMPT
if $GET(ANQX)
QUIT
+12 DO OVRD2
if $GET(ANQX)
QUIT
+13 DO OVRREA
End DoDot:2
QUIT
+14 IF ANQRE=5
Begin DoDot:2
+15 NEW DIR
SET DIR("A")="ANC levels are Critically low. Do you want to Cancel the order"
SET DIR(0)="Y"
SET DIR("B")="N"
+16 DO ^DIR
IF Y=0
DO MSG6^PSOCLUTL
QUIT
+17 IF Y(0)="YES"!($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIROUT))
SET ANQX=1
KILL Q
End DoDot:2
QUIT
+18 IF $GET(ANQRE)=8
Begin DoDot:2
+19 SET ANQX=0
DO OVPRMPT
if $GET(ANQX)
QUIT
+20 DO OVRD2
if $GET(ANQX)
QUIT
+21 DO OVRREA
if $GET(ANQX)
QUIT
+22 DO CRXTMPI(DFN,PSOYS)
End DoDot:2
QUIT
+23 ;/RBN Begin modifications for new special override condition for inpatient
+24 IF ANQRE=9
IF PSTYPE=0
Begin DoDot:2
+25 DO OVPRMPT
if $GET(ANQX)
QUIT
+26 NEW DIR,DIRUT
SET DIR(0)="S^1:Weather Related Conditions;2:Mail Order Delay;3:Inpatient Going On Leave"
+27 SET DIR("A")="Prescriber's reason for Special Condition Override "
DO ^DIR
IF $DATA(DIRUT)
SET ANQX=1
QUIT
+28 SET PSREASON=Y(0)_": "
SET ^TMP($JOB,"CLOZFLG",DFN)=1
+29 DO OVRD2
if $GET(ANQX)
QUIT
+30 DO OVRREA
if $GET(ANQX)
QUIT
+31 SET PSREMARK=PSREASON_PSREMARK
+32 DO CRXTMP(DFN,PSOYS)
End DoDot:2
QUIT
+33 IF ANQRE=9
IF PSTYPE=1
Begin DoDot:2
+34 DO OVPRMPT
if $GET(ANQX)
QUIT
+35 SET PSREASON="IP Order Override with Outside Lab Results: "
SET ^TMP($JOB,"CLOZFLG",DFN)=1
+36 WRITE !,$PIECE(PSREASON,":"),!
+37 DO OVRREA
if $GET(ANQX)
QUIT
+38 DO OVRD2
if $GET(ANQX)
QUIT
+39 SET PSREMARK=PSREASON_PSREMARK
+40 DO CRXTMPI(DFN,PSOYS)
End DoDot:2
QUIT
+41 IF ANQRE=10
Begin DoDot:2
+42 WRITE !,"Test ANC Results 3x weekly until ANC stabilize to greater than or equal to 1500",!
+43 DO OVPRMPT
if $GET(ANQX)
QUIT
+44 DO OVRD2
if $GET(ANQX)
QUIT
+45 DO OVRREA
End DoDot:2
End DoDot:1
+46 ;
+47 IF $GET(ANQX)
DO EXIT
QUIT
+48 ;
+49 SET PSPROVID="UNKNOWN"
+50 IF $DATA(ND0)
SET PSPROVID=$PIECE(ND0,U,2)
SET PSJORN=$PIECE(ND0,U,21)
SET PSJORDER("PSJORN")=PSJORN
+51 IF $DATA(ORO)
SET PSPROVID=$PIECE(ORO,U,4)
SET PSJORN=$PIECE(ORO,U)
SET PSJORDER("PSJORN")=PSJORN
+52 IF '$GET(PSPROVID)
IF $GET(PSTYPE)
IF $GET(PSGOEPR)
SET PSPROVID=+$GET(PSGOEPR)
+53 IF $DATA(DUPRX0)
SET PSPROVID=$PIECE(DUPRX0,U,4)
+54 if ANQRE
SET SANQX=0
SET PSCLPAT=DFN
SET ANQDATA=DUZ_U_PSPROVID_U_ANQRE_U_PSREMARK_U_PSSPHARM_U_PSCLPAT_U_$GET(PSJORN)
+55 ;
GDOSE ; ask daily dose
+1 ; not for inpatient
IF $GET(PSTYPE)
QUIT
+2 NEW IENX,PSOCD,PSRXDOS
+3 ; retrieve DOSAGE ORDERED fields
Begin DoDot:1
+4 ; get parent IEN for new or edited Rx
+5 NEW FLD,IRXNTMP
SET IENX=$SELECT($GET(PSORXED("IRXN")):PSORXED("IRXN"),$GET(PSONEW("IRXN")):PSONEW("IRXN"),1:0)
+6 ; (#301) CLOZAPINE DOSAGE (MG/DAY) [1N]
SET PSRXDOS("CLOZDOSE301")=$$GET1^DIQ(52,IENX,301)
+7 SET IRXNTMP="1,"_IENX
FOR FLD=.01,1:1:9
SET PSRXDOS(FLD)=$$GET1^DIQ(52.0113,IRXNTMP,FLD)
End DoDot:1
+8 ;
DOSE ;
+1 KILL DIR
SET DIR(0)="N^12.5:3000:1"
SET DIR("A")="CLOZAPINE dosage (mg/day)? "
+2 ; default only for standard dose
IF '(PSRXDOS(.01)<12.5)
IF '(PSRXDOS(.01)>900)
SET DIR("B")=PSRXDOS(.01)
+3 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DTOUT)
GOTO EXIT
+4 SET PSOCD=X
+5 ;
+6 IF PSOCD#25=0
IF PSOCD'<12.5
IF PSOCD<900
GOTO EXIT
+7 IF PSOCD#12.5
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")=PSOCD_" is an unusual dose. Are you sure"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
IF 'Y
GOTO DOSE
+8 IF PSOCD>900
SET DIR(0)="Y"
SET DIR("A")="Recommended maximum daily dose is 900. Are you sure"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
IF 'Y
GOTO DOSE
+9 ;
EXIT ;
+1 KILL ^TMP($JOB,"PSO")
+2 if $DATA(DIRUT)
SET ANQX=1
+3 IF $GET(ANQX)
WRITE !!,"No "_PSMSGTXT_" entered!"
HANG 2
QUIT
+4 ;
+5 ; if added to files #55 or #603.01 lab results may be available
DO LABRSLT^PSOCLOU(DFN,.PSOYS,.CLOZPAT)
+6 SET (PSONEW("SAND"),PSOSAND)=PSOCD_U_PSOYS("rWBC")_U_($PIECE($PIECE(PSOYS,U,6),"."))_U_PSOYS("rANC")
+7 NEW NDAYS
SET NDAYS=$SELECT($GET(ANQRE)=9!(PSCLZREG?1U6N):4,CLOZPAT=2:28,CLOZPAT=1:14,1:7)
+8 IF $GET(PSONEW("DAYS SUPPLY"))>NDAYS
Begin DoDot:1
+9 SET PSONEW("DAYS SUPPLY")=NDAYS
SET $PIECE(PSONEW("RX0"),U,8)=NDAYS
+10 ; No DURATION set if 4 DAY SUPPLY
+11 if $GET(NDAYS)'=4
SET PSONEW("DURATION",1)=NDAYS
+12 NEW PSOIENX
SET PSOIENX="1,"_$GET(PSORXIEN)
+13 SET PSONEW("SCHEDULE",1)=$$GET1^DIQ(52.0113,PSOIENX,7)
+14 SET PSONEW("DOSE ORDERED",1)=$$GET1^DIQ(52.0113,PSOIENX,1)
+15 DO QTYCHK(.PSONEW,NDAYS)
End DoDot:1
+16 ; if Rx edited, then update it
+17 ; in case of edits
IF $DATA(PSORXED)
DO EXPDT(.PSORXED,.CLOZPT)
+18 ;
+19 QUIT
+20 ;
OVPRMPT ; ask user to override
+1 NEW DIR
+2 SET DIR("A")="Do you want to override and issue this "_PSMSGTXT
SET DIR(0)="Y"
SET DIR("B")="N"
DO ^DIR
+3 IF 'Y!($DATA(DIROUT)!($DATA(DTOUT)))
SET ANQX=1
+4 QUIT
+5 ;
PKEYCHK ; does user have PSOLOCKCLOZ key
+1 IF '$DATA(PSGSTAT)!($GET(PSGSTAT)="PENDING")
Begin DoDot:1
+2 ; has security key
if $$HASKEY(DUZ)
QUIT
+3 SET ANQX=1
WRITE !,"You Are Not Authorized to Override! See Clozapine Manager with PSOLOCKCLOZ key."
End DoDot:1
+4 QUIT
+5 ;
MH ;
+1 WRITE !!,"Also make sure that the LAB test, ANC is set up correctly in the"
+2 WRITE !,"Mental Health package using the CLOZAPINE MULTI TEST LINK option.",!
+3 QUIT
DSP ; subroutine: NCC remediation PSO*7.0*457
+1 IF 'PSOYS("rWBC")
IF 'PSOYS("rANC")
QUIT
+2 NEW DIR,Y
SET Y=$PIECE($$FMTE^XLFDT($PIECE(PSOYS,U,6)),"@")
+3 WRITE !,"*** Most recent WBC and "_$PIECE(PSOYS,U,5)_" (ANC) results ***"
+4 WRITE !," performed on "_Y_" are: "
+5 WRITE !!," "_$PIECE(PSOYS,U,3)_": "_PSOYS("rWBC")
+6 WRITE !," ANC: "_PSOYS("rANC"),!
+7 SET DIR(0)="EA"
SET DIR("A")="Type <Enter> to continue: "
DO ^DIR
WRITE !
+8 ;
+9 QUIT
DIR ;
+1 WRITE !!
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR,DTOUT,DUOUT,DIRUT
+2 QUIT
+3 ;
END ;
+1 DO MSG5^PSOCLUTL
QU ; no med prescribed
+1 SET ANQX=1
DO DIR
+2 QUIT
+3 ;
NOREG ; Register a new/discontinued non-registered cloz patient
+1 ;
+2 NEW %,I,MSG,MSGNUM,NOW,PSCLZREG,PSO1,PSO2,PSO4,PSONAME,PTINFO,STAT,TMP,X,XMSUB,XMTEXT,Y
+3 ; Check for authorization key
+4 IF '$$HASKEY(DUZ)
Begin DoDot:1
+5 SET ANQX=1
WRITE !,"You Are Not Authorized to Override! See Clozapine Manager with PSOLOCKCLOZ key."
if PSTYPE=1
WRITE !!,"No order entered!"
End DoDot:1
QUIT
+6 ;
+7 WRITE !,"Do you want to register this patient with a temporary local"
+8 WRITE !," authorization number in the Clozapine registry? Y/N "
+9 SET %=2
DO YN^DICN
IF %'=1
SET ANQX=1
WRITE !,"Patient Not Registered",!
QUIT
+10 WRITE !
+11 SET (PSO1,TMP("DFN"))=DFN
+12 SET PSO2=$$FINDNEXT^PSOCLOU
+13 IF PSO2=-1
Begin DoDot:1
+14 WRITE !!,"All emergency registration numbers have been used."
+15 WRITE !,"Emergency registration may no longer be done at this site",!!
+16 WRITE !,"Patient Not Registered",!
End DoDot:1
SET ANQX=1
QUIT
CONT SET TMP("PSO2")=PSO2
+1 SET PSONAME=$$GET1^DIQ(2,PSO1,.01)
+2 SET PSCLOZ=1
SET DFN=TMP("DFN")
+3 ; used in NUMBER1^PSOCLUTL
SET PSO2=TMP("PSO2")
+4 ; Check if registration in file #55 failed or was terminated
+5 SET PTINFO("surname")=$PIECE(PSONAME,",")
SET PTINFO("firstNm")=$PIECE($PIECE(PSONAME,",",2)," ")
+6 SET PTINFO("ssn")=$$GET1^DIQ(2,PSO1,.09)
SET PTINFO("last4")=$EXTRACT(PTINFO("ssn"),6,9)
SET ANQX=1
+7 DO NUMBER1^PSOCLUTL
+8 if $GET(ANQX)
QUIT
+9 ; delete entries in file 603.01 for this patient
SET PSCLZREG=TMP("PSO2")
Begin DoDot:1
+10 NEW DA,DIK
+11 SET DIK="^YSCL(603.01,"
SET DA=""
FOR
SET DA=$ORDER(^YSCL(603.01,"C",DFN,DA))
if DA=""
QUIT
DO ^DIK
End DoDot:1
+12 SET MSG(1)=PSCLZREG_","_PTINFO("surname")_","_PTINFO("firstNm")_","_PTINFO("last4")
+13 SET XMTEXT="MSG("
SET XMSUB="ADD"
+14 NEW YSPROD
SET YSPROD=$$GET1^DIQ(8989.3,1,501,"I")
Begin DoDot:1
+15 ; production account
IF YSPROD
SET XMY("G.RUCLDEM@FO-DALLAS.DOMAIN.EXT")=""
QUIT
+16 ; test account
SET XMY("G.CLOZAPINE ROLL-UP")=""
End DoDot:1
+17 DO ^XMD
+18 SET DFN=TMP("DFN")
+19 IF '$GET(XMMG)
SET MSGNUM=$GET(XMZ)
+20 IF '$TEST
WRITE !!,"Failed to connect with the NCCC."
SET PSOFL=1
QUIT
+21 ; use the server logic for sending a message to populate 55 and 603.01
+22 SET PSCLOZ=1
SET ^TMP($JOB,"CLOZFLG",DFN)=1
SET XMRG=MSG(1)
SET XMFROM=DUZ
SET XQDATE=$$NOW^XLFDT
+23 DO ^YSCLSERV
+24 DO XTMPZRO^PSOCLOU
+25 ; save only temp registration #
if PSCLZREG?1U6N
SET $PIECE(^XTMP("PSJ CLOZ",0),U,4)=PSCLZREG
+26 SET ^XTMP("PSJ CLOZ",DFN)=DT_U_PSCLZREG_U_"A"
+27 ; four days from now
SET ^XTMP("PSJ CLOZ","B",PSCLZREG,DFN)=$$FMADD^XLFDT($$NOW^XLFDT,4)
+28 SET ^XTMP("PSJ CLOZ","C",DFN,PSCLZREG)=""
+29 SET ANQX=0
SET CLOZFLG=1
+30 ; lab results may now be available
DO LABRSLT^PSOCLOU(DFN,.PSOYS,.CLOZPAT)
+31 ;
QUIT ;
+1 QUIT
+2 ;
OVRD2 ;
+1 ; clozapine team member IEN
SET PSSPHARM=""
+2 DO OVRDTMBR^PSOCLOU
+3 ; no team member selected, exit
if 'PSSPHARM
SET ANQX=1
+4 QUIT
+5 ;
OVRREA ; Override reason when order is NCCC Approved
+1 SET ANQX=0
+2 IF $GET(ANQRE)>6
Begin DoDot:1
+3 NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT
+4 SET DIR(0)="F^5:200"
+5 SET DIR("A")="REASON FOR OVERRIDE Remarks"
+6 IF $GET(ANQRE)=9
SET DIR("A")="Remarks: "_$PIECE(PSREASON,":")
+7 SET DIR("?")="Response is 5 to 200 characters."
+8 DO ^DIR
+9 IF $GET(DTOUT)!$GET(DUOUT)!$GET(DIRUT)!$GET(DIROUT)
SET ANQX=1
QUIT
+10 SET PSREMARK=Y
End DoDot:1
+11 QUIT
+12 ;
CHK4REG(PSCLDFN) ; See if patient already has a clozapine registration number
+1 NEW PSCLRSLT
+2 SET PSCLRSLT=$ORDER(^XTMP("PSJ CLOZ","C",PSCLDFN,""))
+3 QUIT PSCLRSLT
+4 ;
CHK4DFN(PSCLRGNO) ; See if this Clozapine registration is assigned
+1 NEW PSCLRSLT
+2 SET PSCLRSLT=$ORDER(^XTMP("PSJ CLOZ","B",PSCLRGNO,""))
+3 QUIT PSCLRSLT
+4 ;
CHK4EXP(PSCLRGNO,PSCLDFN) ; Check for registration expiration
+1 ; returns zero if expired, 1 if not
+2 NEW PSCLRSLT,PSCLZDAT
+3 SET PSCLRSLT=1
+4 IF $DATA(^XTMP("PSJ CLOZ","B",PSCLRGNO,PSCLDFN))
Begin DoDot:1
+5 ; not expired
SET PSCLZDAT=$GET(^XTMP("PSJ CLOZ","B",PSCLRGNO,PSCLDFN))
if '(DT>PSCLZDAT)
QUIT
+6 SET PSCLRSLT=0
if PSCLZDAT>0
SET $PIECE(^XTMP("PSJ CLOZ",PSCLDFN),U,3)="D"
End DoDot:1
+7 ;
+8 QUIT PSCLRSLT
+9 ;
CRXTMP(DFN,PSOYS) ; create XTMP entry for 4 day supply tracking
+1 IF $GET(DFN)
DO CRXTMP^PSOCLUTL(DFN,PSOYS)
+2 QUIT
CRXTMPI(DFN,PSOYS) ; create XTMP entry for 4 day supply tracking
+1 IF $GET(DFN)
DO CRXTMPI^PSOCLUTL(DFN,PSOYS)
+2 QUIT
+3 ;
HASKEY(USRNUM) ; Boolean function, does USRNUM hold the PSOLOCKCLOZ security key?
+1 ; default to current user
IF '$GET(USRNUM)>0
SET USRNUM=DUZ
+2 QUIT $SELECT($DATA(^XUSEC("PSOLOCKCLOZ",USRNUM)):1,1:0)
+3 ;
EXPDT(PSORXARY,CLOZPT) ; PSORXARY,CLOZPAT passed by ref., determine expiration date (for Clozapine only)
+1 ; PSORXARY can be a new Rx (PSONEW) or an edited Rx (PSORXED and PSODIR)
+2 ; must have IEN
if '($GET(PSORXARY("IRXN"))>0)
QUIT
+3 ; Check for updates to DAYS SUPPLY, ISSUE DATE and QUANTITY
+4 NEW D,DYS2EXPR,PSRXFMDT,PSCLUPDT,NUMREFS
+5 SET PSCLUPDT("change")=0
+6 if $GET(PSORXARY("DAYS SUPPLY"))
SET PSCLUPDT("change")=1
+7 if $GET(PSORXARY("FLD",1))
SET PSCLUPDT("change")=1
+8 if $GET(PSORXARY("QTY"))
SET PSCLUPDT("change")=1
+9 IF $DATA(PSORXARY("N# REF"))
Begin DoDot:1
+10 SET NUMREFS=+$GET(PSORXARY("N# REF"))
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET NUMREFS=+$PIECE($GET(PSORXARY("RX0")),U,9)
End DoDot:1
+13 ; no changes, exit
if 'PSCLUPDT("change")
QUIT
+14 ; days to expire
SET DYS2EXPR=0
+15 ; field #1
SET PSRXFMDT(1)=0
+16 ; determine ISSUE DATE
Begin DoDot:1
+17 ; field may have been edited
SET PSRXFMDT(1)=$GET(PSORXARY("FLD",1))
+18 ; date found
if PSRXFMDT(1)?7N
QUIT
+19 ; (#1) ISSUE DATE [13D]
SET PSRXFMDT(1)=$$GET1^DIQ(52,PSORXARY("IRXN")_",",1,"I")
+20 if PSRXFMDT(1)
QUIT
+21 ; last resort
SET PSRXFMDT(1)=DT
End DoDot:1
+22 ;
+23 ; determine days to expire
Begin DoDot:1
+24 SET D=$GET(PSORXARY("DAYS SUPPLY"))
if D>0
SET DYS2EXPR=D*(NUMREFS+1)
+25 IF D
IF $GET(PSORXARY("DAYS SUPPLY OLD"))
SET PSCLUPDT(8)=PSORXARY("DAYS SUPPLY")
+26 if DYS2EXPR
QUIT
+27 SET D=$PIECE($GET(PSORXARY("RX0")),U,8)
IF D>0
SET DYS2EXPR=D*(NUMREFS+1)
QUIT
+28 ; default
SET DYS2EXPR=$SELECT(CLOZPAT=2:28,CLOZPAT=1:14,1:7)
End DoDot:1
+29 ; value for FM call
+30 SET PSRXFMDT("expires")=$$FMADD^XLFDT(PSRXFMDT(1),DYS2EXPR)
+31 ; (#26) EXPIRATION DATE [6D]
SET PSCLUPDT(26)=PSRXFMDT("expires")
+32 SET PSORXARY("CLOZ EDIT")=PSCLUPDT(26)
+33 IF $GET(PSORXARY("DAYS SUPPLY"))
Begin DoDot:1
+34 DO QTYCHK(.PSORXARY,PSORXARY("DAYS SUPPLY"))
+35 ; only if quantity changed
+36 ; (#7) QTY [7N]
IF $GET(PSORXARY("QTY"))
SET PSCLUPDT(7)=PSORXARY("QTY")
End DoDot:1
+37 ;
+38 ; update PSORXARY("FLD") nodes to include any edits
+39 ; QTY (#7), DAYS SUPPLY (#8), EXPIRATION DATE (#26)
+40 FOR D=7,8,26
IF $GET(PSCLUPDT(D))
SET PSORXARY("FLD",D)=PSCLUPDT(D)
+41 ; (#8) DAYS SUPPLY [8N]
IF $GET(PSCLUPDT(8))
SET $PIECE(PSORXARY("RX0"),U,8)=PSCLUPDT(8)
+42 ; (#26) EXPIRATION DATE [6D]
IF $GET(PSCLUPDT(26))
SET $PIECE(PSORXARY("RX2"),U,6)=PSCLUPDT(26)
+43 ;
+44 QUIT
+45 ;
QTYCHK(PSORXARY,NUMDAYS) ; check/adjust quantity, PSORXARY passed by ref., NUMDAYS is # of days
+1 ; required
if '($GET(NUMDAYS)>0)
QUIT
+2 DO QTYCHK^PSOCLUTL(.PSORXARY,NUMDAYS)
+3 QUIT
