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

PSOCLO1.m

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