- 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 Feb 18, 2025@23:51:52 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