PSOCLOU ; HEC/hrub - clozapine support utilities ;26 DEC 2019 6:26:10
;;7.0;OUTPATIENT PHARMACY;**457,574**;DEC 1997;Build 53
;
; 29 April 2019 - code moved from PSOCLO1 for PSO*7*457
;
Q
;
ANCWARN(PSOYS) ; ANC warnings
I PSOYS("rANC")<1000 W !,"Test ANC labs daily until levels stabilize to ANC greater than or equal to 1000.",! Q
I PSOYS("rANC")<1500 W !,"Test ANC labs 3x weekly until levels stabilize to greater than or equal to 1500.",!
Q
;
NOTAUTH ;
W !!,"You Are Not Authorized to Override! See Clozapine Manager with PSOLOCKCLOZ key."
Q
;
AUTHMSG ;
W !!,"Permission to dispense clozapine has been authorized by NCCC.",!
Q
;
CLOZDISP(PRVDRIEN) ; Boolean function, does PRVDRIEN have (DEA# or VA#) and the YSCL AUTHORIZED key?
;
Q:'($G(PRVDRIEN)>0) "" ; return null for bad input
N NMBR,RSLT,X S RSLT=0,NMBR=0
; providers may have both DEA# and VA#
S:$L($$GET1^DIQ(200,PRVDRIEN,53.2)) NMBR=NMBR+1 ; (#53.2) DEA# [2F]
S:$L($$GET1^DIQ(200,PRVDRIEN,53.3)) NMBR=NMBR+1 ; (#53.3) VA# [3F]
I NMBR S:$D(^XUSEC("YSCL AUTHORIZED",PRVDRIEN)) RSLT=1
Q RSLT
;
CLZPTNFO(PTNFO,CLZDFN) ; clozapine patient info, PTNFO passed by ref.
;
Q:'($G(CLZDFN)>0) ; must have DFN
N C,IEN,X K PTNFO
S PTNFO(55,"pharmDFN")=$$GET1^DIQ(55,CLZDFN,.01,"I") D:PTNFO(55,"pharmDFN") ; if patient in file #55
. S PTNFO(55,"clozReg#")=$$GET1^DIQ(55,CLZDFN,53) ; (#53) CLOZAPINE REGISTRATION NUMBER
. S PTNFO(55,"clozStatus")=$$GET1^DIQ(55,CLZDFN,54,"I") ; (#54) CLOZAPINE STATUS
. S PTNFO(55,"clozPrvdr")=$$GET1^DIQ(55,CLZDFN,57,"I") ; (#57) RESPONSIBLE PROVIDER
. S PTNFO(55,"clozRegDt")=$$GET1^DIQ(55,CLZDFN,58,"I") ; (#58) REGISTRATION DATE
;
Q:'PTNFO(55,"pharmDFN") ; stop if not in file #55
;
I $L($G(XQY0)) D
. S:XQY0["PSO" PTNFO("pharmStat")="OUT"
. S:XQY0["PSJ" PTNFO("pharmStat")="IN"
;
S PTNFO(2,"wardLoc")=$$GET1^DIQ(2,CLZDFN,.1) ; (#.1) WARD LOCATION
;
S X=$$CL^YSCLTST2(CLZDFN),PTNFO("lab","WBC")="",PTNFO("lab","ANC")="",PTNFO("labNm","WBC")="",PTNFO("labNm","ANC")=""
I '(X<0) D ; lab test names and results
. S PTNFO("ysRslt")=X,PTNFO("lab","dt")=$P(X,U,6)
. S PTNFO("labNm","WBC")=$P(X,U,3) S:$L(PTNFO("labNm","WBC")) PTNFO("lab","WBC")=+$P(X,U,2)
. S PTNFO("labNm","ANC")=$P(X,U,5) S:$L(PTNFO("labNm","ANC")) PTNFO("lab","ANC")=+$P(X,U,4)
;
S C=0,IEN=0 ; entry count & ien
F S IEN=$O(^YSCL(603.01,"C",CLZDFN,IEN)) Q:'IEN S C=C+1 D ; get file #603.01 info, may be duplicates
. S PTNFO(603.01,IEN,"cloz#")=$$GET1^DIQ(603.01,IEN,.01) ; (#.01) CLOZAPINE REGISTRATION NUMBER
. S PTNFO(603.01,IEN,"clozDFN")=$$GET1^DIQ(603.01,IEN,1,"I") ; (#1) CLOZAPINE PATIENT
. S PTNFO(603.01,IEN,"dispFrq")=$$GET1^DIQ(603.01,IEN,2,"I") ; (#2) DISPENSE FREQUENCY
. S PTNFO(603.01,IEN,"ovrdDt")=$$GET1^DIQ(603.01,IEN,3,"I") ; (#3) OVERRIDE DATE
;
S PTNFO(603.01,0,"total")=C
;
Q
;
FINDNEXT() ; Find the next pseudo Clozapine registration number, return -1 if none left
D DT^DICRW
N N,NUM,PRFIX,RGRSLT,RGZRO,STNUM,Y
D XTMPZRO
S STNUM=+$P($$SITE^VASITE,U,3),RGZRO=$G(^XTMP("PSJ CLOZ",0)),Y=$P(RGZRO,U,4)
S PRFIX=$E(Y) ; last temp registration prefix
I '(PRFIX]"A") S N=0,Y=STNUM_"999" D I N Q -1 ; no more temp numbers
. S:$D(^XTMP("PSJ CLOZ","B",Y)) N=1 Q:N
. S:$D(^YSCL(603.01,"B",Y)) N=1 Q:N
. S:$D(^PS(55,"ASAND1",Y)) N=1
S:'(PRFIX?1U) PRFIX="Z" ; start at Z if no prefix found
S N=0 F L +^XTMP("PSJ CLOZ",0):DILOCKTM S Y=$T Q:Y!(N>2) S N=N+Y ; try until LOCK or 3 attempts
I 'Y Q -1 ; couldn't get a LOCK
;ajf ; Defect 1181858 - Setting temp number
;S NUM=+$E(RGZRO,5,7) ; numeric value after station #
S NUM=+$E($P(RGZRO,"^",4),5,7) ; numeric value after station #
I (NUM<0)!(NUM>998) S NUM=0 ; adjust if needed
S RGRSLT="" ; registration number to return
F D Q:$L(RGRSLT)
. S N=1000+NUM ; pad NUM
. S Y=PRFIX_STNUM_($E(N,2,4)) ; potential registration number
. ; check if registration number in use
. I '$D(^XTMP("PSJ CLOZ","B",Y)),'$D(^YSCL(603.01,"B",Y)),'$D(^PS(55,"ASAND1",Y)) S RGRSLT=Y Q
. S NUM=NUM+1 Q:NUM<1000 ; keep looking on same prefix
. S Y=$E(PRFIX),Y=$C($A(Y)-1),PRFIX=Y ; make 1st char. of prefix previous ASCII character
. I ("A"]PRFIX) S RGRSLT=-1 Q ; No more pseudo numbers left
. S NUM=0 ; reset counter
;
L -^XTMP("PSJ CLOZ",0)
Q RGRSLT
;
LABRSLT(DFN,PSOYS,CLOZPAT) ; get lab tests
; PSOYS, CLOZPAT both passed by ref.
N X
S PSOYS=$$CL^YSCLTST2(DFN),PSOYS("rWBC")="",PSOYS("rANC")=""
D:'(PSOYS<0) ; if less than zero no lab tests
. S X=$P(PSOYS,U,2) S:$L(X) PSOYS("rWBC")=+X ; WBC result
. S X=$P(PSOYS,U,4) S:$L(X) PSOYS("rANC")=+X ; ANC result
S X=$P(PSOYS,U,7),CLOZPAT=$S(X="M":2,X="B":1,1:0)
Q
;
OVRDRSN(DFN,PSOYS,PSCLZREG,CLOZPAT) ; function, return override reason
;PSOYS, PSCLZREG, CLOZPAT passed by ref.
N OVRDRSN S OVRDRSN=""
;
D LABRSLT(DFN,.PSOYS,.CLOZPAT) ; update lab results
S PSCLZREG=$$GET1^DIQ(55,DFN,53),PSCLZREG("status55")=$$GET1^DIQ(55,DFN,54,"I")
;
I $$OVERRIDE^YSCLTST2(DFN,0) S OVRDRSN=7 ; NCCC AUTHORIZED
; no reg # or (temp. reg # and active)
I 'OVRDRSN,PSCLZREG=""!((PSCLZREG?1U6N)&(PSCLZREG("status55")="A")) D
. Q:PSOYS("rANC")<1500 ; must be at least 1500
. Q:'$L(PSOYS("rWBC")) ; must have WBC result (any value)
. S OVRDRSN=8 ; REGISTER NON-DUTY HR/WEEKEND (MAX4DAY)
;
I 'OVRDRSN,PSCLZREG("status55")="A",PSCLZREG?2U5N D ; active, normal reg #
. ; if no ANC reult, return 9
. I '($L(PSOYS("rANC"))) S OVRDRSN=9 Q ;PRESCRIBER APPROVED 4 DAY SUPPLY
;
I 'OVRDRSN,PSCLZREG("status55")="A",PSCLZREG?2U5N D ; active, normal reg #
. I PSOYS("rANC")<1500&'(PSOYS("rANC")<1000) S OVRDRSN=10 ; MILD NEUTROPENIA PRESCRIBER APPROVED
;
Q OVRDRSN
;
OVRDTMBR ; select override team member, returned in PSSPHARM
S ANQX=0 ; flag, exit clozapine logic
S PSSPHARM="" ; null if no selection
N CNT,DIR,IEN,LPXIT,PSOTMND,R,V,X,Y
S PSOTMND="PSO CLOZ TEAM"
K ^TMP($J,PSOTMND)
S ^TMP($J,PSOTMND,0,"date")=$P($$FMTE^XLFDT($$NOW^XLFDT),"@")
S ^TMP($J,PSOTMND,0,"duzXcld")=0 ; indicates user was excluded
; create alphabetic list of key holders
S IEN=0 F S IEN=$O(^XUSEC("PSOLOCKCLOZ",IEN)) Q:'IEN D
. I IEN=DUZ S ^TMP($J,PSOTMND,0,"duzXcld")=IEN Q ; set flag, exclude user from list
. Q:$$GET1^DIQ(200,IEN_",",7,"I") ; (#7) DISUSER [7S], skip if set
. S X=$$GET1^DIQ(200,IEN_",",2,"I") Q:X="" ; (#2) ACCESS CODE [3F], skip if null
. S X=$$GET1^DIQ(200,IEN_",",.01) Q:X=""
. S ^TMP($J,PSOTMND,"B",X,IEN)=""
; count members, create numeric list
S CNT=0,V=$NA(^TMP($J,PSOTMND,"B"))
F S V=$Q(@V) Q:V="" Q:'($QS(V,2)=PSOTMND) D
. S IEN=$QS(V,5),Y=$QS(V,4)_" (user #"_IEN_")"
. S CNT=CNT+1,^TMP($J,PSOTMND,CNT)=Y
. S ^TMP($J,PSOTMND,CNT,"IEN")=IEN
;
S ^TMP($J,PSOTMND,0)=CNT
I CNT=0 D Q
. S ANQX=1 ; no member selected
. W !!,"No active approving members available"_$S(^TMP($J,PSOTMND,0,"duzXcld"):" (other than you).",1:".")
. S DIR(0)="EA",DIR("A")="Enter: " D ^DIR
. K ^TMP($J,PSOTMND)
;
S LPXIT=0 F D Q:LPXIT
. D DISPTM(PSOTMND)
. N MMBRNO K DIR S R=^TMP($J,PSOTMND,0)
. S DIR(0)="NA^1:"_R,DIR("A")="Select Approving Team Member or '^' to exit (1-"_R_"): "
. S DIR("?")="Enter an integer to select from the list"_$S(^TMP($J,PSOTMND,0,"duzXcld"):" (you were excluded).",1:".")
. S DIR("A",1)=" " D ^DIR
. I 'Y!$D(DUOUT)!$D(DTOUT) S ANQX=1,LPXIT=1 Q ; no member selected
. S MMBRNO=Y
. K DIR S DIR(0)="YA",DIR("A")="Is this correct? ",DIR("B")="NO"
. S DIR("A",1)=" ",DIR("A",2)="You selected "_^TMP($J,PSOTMND,MMBRNO)
. D ^DIR I $D(DUOUT)!$D(DTOUT) S LPXIT=1,ANQX=1 Q ; time out or '^', no member selected
. Q:'Y S PSSPHARM=^TMP($J,PSOTMND,MMBRNO,"IEN"),LPXIT=1
;
K ^TMP($J,PSOTMND) ; clean up
Q
;
DISPTM(PSOTMND) ; display team members
Q:$G(PSOTMND)=""
Q:'$G(^TMP($J,PSOTMND,0)) ; nothing to display
N CNT,DIR,DUOUT,LPXIT,R
W !!," Clozapine Team Members "_$G(^TMP($J,PSOTMND,0,"date")),!
S (CNT,LPXIT,R)=0
F S CNT=$O(^TMP($J,PSOTMND,CNT)) Q:'CNT!LPXIT S Y=^(CNT) D
. S R=R+1 W !,$J(CNT,3)_". "_Y Q:(R<20) ; display 20 at a time
. Q:'$O(^TMP($J,PSOTMND,CNT)) ; nothing left to display
. K DIR,DUOUT S DIR(0)="EA",DIR("A")="<ENTER> to see more members, '^' to exit: "
. D ^DIR S R=0 S:$D(DUOUT) LPXIT=1
;
Q
;
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
; ** NCC REMEDIATION add new reasons 8-11 ** 457/RTW 11 ;;EMERGENCY OVERRIDE NO ANC LAST 7 DAYS
OVRDTXT(RSNCODE) ; function, return text for override
Q:'($G(RSNCODE)>0) "" ; no reason code, return null
Q:$G(RSNCODE)=1 "NO WBC IN LAST 7 DAYS"
Q:$G(RSNCODE)=2 "NO VERIFIED WBC"
Q:$G(RSNCODE)=3 "LAST WBC RESULT < 3500"
Q:$G(RSNCODE)=4 "3 SEQ. WBC DECREASE"
Q:$G(RSNCODE)=5 "LAST ANC RESULT < 2000"
Q:$G(RSNCODE)=6 "SEQ. ANC DECREASE"
Q:$G(RSNCODE)=7 "NCCC AUTHORIZED"
Q:$G(RSNCODE)=8 "REGISTER NON-DUTY HR/WEEKEND (MAX 4DAY)"
Q:$G(RSNCODE)=9 "PRESCRIBER APPROVED 4 DAY SUPPLY"
Q:$G(RSNCODE)=10 "MILD NEUTROPENIA PRESCRIBER APPROVED"
Q "" ; shouldn't get here, return null
;
HASKEY(USRNUM) ; Boolean function, does USRNUM hold the PSOLOCKCLOZ security key?
I '($G(USRNUM)>0) S USRNUM=DUZ ; default to current user
Q $D(^XUSEC("PSOLOCKCLOZ",USRNUM))
;
XTMPZRO ;set zero node in ^XTMP("PSJ CLOZ")
N Y
S Y=$$FMADD^XLFDT($$DT^XLFDT,366) ; one year (366 days) in the future
S $P(^XTMP("PSJ CLOZ",0),U)=Y,$P(^XTMP("PSJ CLOZ",0),U,2)=DT,$P(^XTMP("PSJ CLOZ",0),U,3)="CLOZAPINE WEEKEND REGISTRATION"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCLOU 9718 printed Dec 13, 2024@02:25:27 Page 2
PSOCLOU ; HEC/hrub - clozapine support utilities ;26 DEC 2019 6:26:10
+1 ;;7.0;OUTPATIENT PHARMACY;**457,574**;DEC 1997;Build 53
+2 ;
+3 ; 29 April 2019 - code moved from PSOCLO1 for PSO*7*457
+4 ;
+5 QUIT
+6 ;
ANCWARN(PSOYS) ; ANC warnings
+1 IF PSOYS("rANC")<1000
WRITE !,"Test ANC labs daily until levels stabilize to ANC greater than or equal to 1000.",!
QUIT
+2 IF PSOYS("rANC")<1500
WRITE !,"Test ANC labs 3x weekly until levels stabilize to greater than or equal to 1500.",!
+3 QUIT
+4 ;
NOTAUTH ;
+1 WRITE !!,"You Are Not Authorized to Override! See Clozapine Manager with PSOLOCKCLOZ key."
+2 QUIT
+3 ;
AUTHMSG ;
+1 WRITE !!,"Permission to dispense clozapine has been authorized by NCCC.",!
+2 QUIT
+3 ;
CLOZDISP(PRVDRIEN) ; Boolean function, does PRVDRIEN have (DEA# or VA#) and the YSCL AUTHORIZED key?
+1 ;
+2 ; return null for bad input
if '($GET(PRVDRIEN)>0)
QUIT ""
+3 NEW NMBR,RSLT,X
SET RSLT=0
SET NMBR=0
+4 ; providers may have both DEA# and VA#
+5 ; (#53.2) DEA# [2F]
if $LENGTH($$GET1^DIQ(200,PRVDRIEN,53.2))
SET NMBR=NMBR+1
+6 ; (#53.3) VA# [3F]
if $LENGTH($$GET1^DIQ(200,PRVDRIEN,53.3))
SET NMBR=NMBR+1
+7 IF NMBR
if $DATA(^XUSEC("YSCL AUTHORIZED",PRVDRIEN))
SET RSLT=1
+8 QUIT RSLT
+9 ;
CLZPTNFO(PTNFO,CLZDFN) ; clozapine patient info, PTNFO passed by ref.
+1 ;
+2 ; must have DFN
if '($GET(CLZDFN)>0)
QUIT
+3 NEW C,IEN,X
KILL PTNFO
+4 ; if patient in file #55
SET PTNFO(55,"pharmDFN")=$$GET1^DIQ(55,CLZDFN,.01,"I")
if PTNFO(55,"pharmDFN")
Begin DoDot:1
+5 ; (#53) CLOZAPINE REGISTRATION NUMBER
SET PTNFO(55,"clozReg#")=$$GET1^DIQ(55,CLZDFN,53)
+6 ; (#54) CLOZAPINE STATUS
SET PTNFO(55,"clozStatus")=$$GET1^DIQ(55,CLZDFN,54,"I")
+7 ; (#57) RESPONSIBLE PROVIDER
SET PTNFO(55,"clozPrvdr")=$$GET1^DIQ(55,CLZDFN,57,"I")
+8 ; (#58) REGISTRATION DATE
SET PTNFO(55,"clozRegDt")=$$GET1^DIQ(55,CLZDFN,58,"I")
End DoDot:1
+9 ;
+10 ; stop if not in file #55
if 'PTNFO(55,"pharmDFN")
QUIT
+11 ;
+12 IF $LENGTH($GET(XQY0))
Begin DoDot:1
+13 if XQY0["PSO"
SET PTNFO("pharmStat")="OUT"
+14 if XQY0["PSJ"
SET PTNFO("pharmStat")="IN"
End DoDot:1
+15 ;
+16 ; (#.1) WARD LOCATION
SET PTNFO(2,"wardLoc")=$$GET1^DIQ(2,CLZDFN,.1)
+17 ;
+18 SET X=$$CL^YSCLTST2(CLZDFN)
SET PTNFO("lab","WBC")=""
SET PTNFO("lab","ANC")=""
SET PTNFO("labNm","WBC")=""
SET PTNFO("labNm","ANC")=""
+19 ; lab test names and results
IF '(X<0)
Begin DoDot:1
+20 SET PTNFO("ysRslt")=X
SET PTNFO("lab","dt")=$PIECE(X,U,6)
+21 SET PTNFO("labNm","WBC")=$PIECE(X,U,3)
if $LENGTH(PTNFO("labNm","WBC"))
SET PTNFO("lab","WBC")=+$PIECE(X,U,2)
+22 SET PTNFO("labNm","ANC")=$PIECE(X,U,5)
if $LENGTH(PTNFO("labNm","ANC"))
SET PTNFO("lab","ANC")=+$PIECE(X,U,4)
End DoDot:1
+23 ;
+24 ; entry count & ien
SET C=0
SET IEN=0
+25 ; get file #603.01 info, may be duplicates
FOR
SET IEN=$ORDER(^YSCL(603.01,"C",CLZDFN,IEN))
if 'IEN
QUIT
SET C=C+1
Begin DoDot:1
+26 ; (#.01) CLOZAPINE REGISTRATION NUMBER
SET PTNFO(603.01,IEN,"cloz#")=$$GET1^DIQ(603.01,IEN,.01)
+27 ; (#1) CLOZAPINE PATIENT
SET PTNFO(603.01,IEN,"clozDFN")=$$GET1^DIQ(603.01,IEN,1,"I")
+28 ; (#2) DISPENSE FREQUENCY
SET PTNFO(603.01,IEN,"dispFrq")=$$GET1^DIQ(603.01,IEN,2,"I")
+29 ; (#3) OVERRIDE DATE
SET PTNFO(603.01,IEN,"ovrdDt")=$$GET1^DIQ(603.01,IEN,3,"I")
End DoDot:1
+30 ;
+31 SET PTNFO(603.01,0,"total")=C
+32 ;
+33 QUIT
+34 ;
FINDNEXT() ; Find the next pseudo Clozapine registration number, return -1 if none left
+1 DO DT^DICRW
+2 NEW N,NUM,PRFIX,RGRSLT,RGZRO,STNUM,Y
+3 DO XTMPZRO
+4 SET STNUM=+$PIECE($$SITE^VASITE,U,3)
SET RGZRO=$GET(^XTMP("PSJ CLOZ",0))
SET Y=$PIECE(RGZRO,U,4)
+5 ; last temp registration prefix
SET PRFIX=$EXTRACT(Y)
+6 ; no more temp numbers
IF '(PRFIX]"A")
SET N=0
SET Y=STNUM_"999"
Begin DoDot:1
+7 if $DATA(^XTMP("PSJ CLOZ","B",Y))
SET N=1
if N
QUIT
+8 if $DATA(^YSCL(603.01,"B",Y))
SET N=1
if N
QUIT
+9 if $DATA(^PS(55,"ASAND1",Y))
SET N=1
End DoDot:1
IF N
QUIT -1
+10 ; start at Z if no prefix found
if '(PRFIX?1U)
SET PRFIX="Z"
+11 ; try until LOCK or 3 attempts
SET N=0
FOR
LOCK +^XTMP("PSJ CLOZ",0):DILOCKTM
SET Y=$TEST
if Y!(N>2)
QUIT
SET N=N+Y
+12 ; couldn't get a LOCK
IF 'Y
QUIT -1
+13 ;ajf ; Defect 1181858 - Setting temp number
+14 ;S NUM=+$E(RGZRO,5,7) ; numeric value after station #
+15 ; numeric value after station #
SET NUM=+$EXTRACT($PIECE(RGZRO,"^",4),5,7)
+16 ; adjust if needed
IF (NUM<0)!(NUM>998)
SET NUM=0
+17 ; registration number to return
SET RGRSLT=""
+18 FOR
Begin DoDot:1
+19 ; pad NUM
SET N=1000+NUM
+20 ; potential registration number
SET Y=PRFIX_STNUM_($EXTRACT(N,2,4))
+21 ; check if registration number in use
+22 IF '$DATA(^XTMP("PSJ CLOZ","B",Y))
IF '$DATA(^YSCL(603.01,"B",Y))
IF '$DATA(^PS(55,"ASAND1",Y))
SET RGRSLT=Y
QUIT
+23 ; keep looking on same prefix
SET NUM=NUM+1
if NUM<1000
QUIT
+24 ; make 1st char. of prefix previous ASCII character
SET Y=$EXTRACT(PRFIX)
SET Y=$CHAR($ASCII(Y)-1)
SET PRFIX=Y
+25 ; No more pseudo numbers left
IF ("A"]PRFIX)
SET RGRSLT=-1
QUIT
+26 ; reset counter
SET NUM=0
End DoDot:1
if $LENGTH(RGRSLT)
QUIT
+27 ;
+28 LOCK -^XTMP("PSJ CLOZ",0)
+29 QUIT RGRSLT
+30 ;
LABRSLT(DFN,PSOYS,CLOZPAT) ; get lab tests
+1 ; PSOYS, CLOZPAT both passed by ref.
+2 NEW X
+3 SET PSOYS=$$CL^YSCLTST2(DFN)
SET PSOYS("rWBC")=""
SET PSOYS("rANC")=""
+4 ; if less than zero no lab tests
if '(PSOYS<0)
Begin DoDot:1
+5 ; WBC result
SET X=$PIECE(PSOYS,U,2)
if $LENGTH(X)
SET PSOYS("rWBC")=+X
+6 ; ANC result
SET X=$PIECE(PSOYS,U,4)
if $LENGTH(X)
SET PSOYS("rANC")=+X
End DoDot:1
+7 SET X=$PIECE(PSOYS,U,7)
SET CLOZPAT=$SELECT(X="M":2,X="B":1,1:0)
+8 QUIT
+9 ;
OVRDRSN(DFN,PSOYS,PSCLZREG,CLOZPAT) ; function, return override reason
+1 ;PSOYS, PSCLZREG, CLOZPAT passed by ref.
+2 NEW OVRDRSN
SET OVRDRSN=""
+3 ;
+4 ; update lab results
DO LABRSLT(DFN,.PSOYS,.CLOZPAT)
+5 SET PSCLZREG=$$GET1^DIQ(55,DFN,53)
SET PSCLZREG("status55")=$$GET1^DIQ(55,DFN,54,"I")
+6 ;
+7 ; NCCC AUTHORIZED
IF $$OVERRIDE^YSCLTST2(DFN,0)
SET OVRDRSN=7
+8 ; no reg # or (temp. reg # and active)
+9 IF 'OVRDRSN
IF PSCLZREG=""!((PSCLZREG?1U6N)&(PSCLZREG("status55")="A"))
Begin DoDot:1
+10 ; must be at least 1500
if PSOYS("rANC")<1500
QUIT
+11 ; must have WBC result (any value)
if '$LENGTH(PSOYS("rWBC"))
QUIT
+12 ; REGISTER NON-DUTY HR/WEEKEND (MAX4DAY)
SET OVRDRSN=8
End DoDot:1
+13 ;
+14 ; active, normal reg #
IF 'OVRDRSN
IF PSCLZREG("status55")="A"
IF PSCLZREG?2U5N
Begin DoDot:1
+15 ; if no ANC reult, return 9
+16 ;PRESCRIBER APPROVED 4 DAY SUPPLY
IF '($LENGTH(PSOYS("rANC")))
SET OVRDRSN=9
QUIT
End DoDot:1
+17 ;
+18 ; active, normal reg #
IF 'OVRDRSN
IF PSCLZREG("status55")="A"
IF PSCLZREG?2U5N
Begin DoDot:1
+19 ; MILD NEUTROPENIA PRESCRIBER APPROVED
IF PSOYS("rANC")<1500&'(PSOYS("rANC")<1000)
SET OVRDRSN=10
End DoDot:1
+20 ;
+21 QUIT OVRDRSN
+22 ;
OVRDTMBR ; select override team member, returned in PSSPHARM
+1 ; flag, exit clozapine logic
SET ANQX=0
+2 ; null if no selection
SET PSSPHARM=""
+3 NEW CNT,DIR,IEN,LPXIT,PSOTMND,R,V,X,Y
+4 SET PSOTMND="PSO CLOZ TEAM"
+5 KILL ^TMP($JOB,PSOTMND)
+6 SET ^TMP($JOB,PSOTMND,0,"date")=$PIECE($$FMTE^XLFDT($$NOW^XLFDT),"@")
+7 ; indicates user was excluded
SET ^TMP($JOB,PSOTMND,0,"duzXcld")=0
+8 ; create alphabetic list of key holders
+9 SET IEN=0
FOR
SET IEN=$ORDER(^XUSEC("PSOLOCKCLOZ",IEN))
if 'IEN
QUIT
Begin DoDot:1
+10 ; set flag, exclude user from list
IF IEN=DUZ
SET ^TMP($JOB,PSOTMND,0,"duzXcld")=IEN
QUIT
+11 ; (#7) DISUSER [7S], skip if set
if $$GET1^DIQ(200,IEN_",",7,"I")
QUIT
+12 ; (#2) ACCESS CODE [3F], skip if null
SET X=$$GET1^DIQ(200,IEN_",",2,"I")
if X=""
QUIT
+13 SET X=$$GET1^DIQ(200,IEN_",",.01)
if X=""
QUIT
+14 SET ^TMP($JOB,PSOTMND,"B",X,IEN)=""
End DoDot:1
+15 ; count members, create numeric list
+16 SET CNT=0
SET V=$NAME(^TMP($JOB,PSOTMND,"B"))
+17 FOR
SET V=$QUERY(@V)
if V=""
QUIT
if '($QSUBSCRIPT(V,2)=PSOTMND)
QUIT
Begin DoDot:1
+18 SET IEN=$QSUBSCRIPT(V,5)
SET Y=$QSUBSCRIPT(V,4)_" (user #"_IEN_")"
+19 SET CNT=CNT+1
SET ^TMP($JOB,PSOTMND,CNT)=Y
+20 SET ^TMP($JOB,PSOTMND,CNT,"IEN")=IEN
End DoDot:1
+21 ;
+22 SET ^TMP($JOB,PSOTMND,0)=CNT
+23 IF CNT=0
Begin DoDot:1
+24 ; no member selected
SET ANQX=1
+25 WRITE !!,"No active approving members available"_$SELECT(^TMP($JOB,PSOTMND,0,"duzXcld"):" (other than you).",1:".")
+26 SET DIR(0)="EA"
SET DIR("A")="Enter: "
DO ^DIR
+27 KILL ^TMP($JOB,PSOTMND)
End DoDot:1
QUIT
+28 ;
+29 SET LPXIT=0
FOR
Begin DoDot:1
+30 DO DISPTM(PSOTMND)
+31 NEW MMBRNO
KILL DIR
SET R=^TMP($JOB,PSOTMND,0)
+32 SET DIR(0)="NA^1:"_R
SET DIR("A")="Select Approving Team Member or '^' to exit (1-"_R_"): "
+33 SET DIR("?")="Enter an integer to select from the list"_$SELECT(^TMP($JOB,PSOTMND,0,"duzXcld"):" (you were excluded).",1:".")
+34 SET DIR("A",1)=" "
DO ^DIR
+35 ; no member selected
IF 'Y!$DATA(DUOUT)!$DATA(DTOUT)
SET ANQX=1
SET LPXIT=1
QUIT
+36 SET MMBRNO=Y
+37 KILL DIR
SET DIR(0)="YA"
SET DIR("A")="Is this correct? "
SET DIR("B")="NO"
+38 SET DIR("A",1)=" "
SET DIR("A",2)="You selected "_^TMP($JOB,PSOTMND,MMBRNO)
+39 ; time out or '^', no member selected
DO ^DIR
IF $DATA(DUOUT)!$DATA(DTOUT)
SET LPXIT=1
SET ANQX=1
QUIT
+40 if 'Y
QUIT
SET PSSPHARM=^TMP($JOB,PSOTMND,MMBRNO,"IEN")
SET LPXIT=1
End DoDot:1
if LPXIT
QUIT
+41 ;
+42 ; clean up
KILL ^TMP($JOB,PSOTMND)
+43 QUIT
+44 ;
DISPTM(PSOTMND) ; display team members
+1 if $GET(PSOTMND)=""
QUIT
+2 ; nothing to display
if '$GET(^TMP($JOB,PSOTMND,0))
QUIT
+3 NEW CNT,DIR,DUOUT,LPXIT,R
+4 WRITE !!," Clozapine Team Members "_$GET(^TMP($JOB,PSOTMND,0,"date")),!
+5 SET (CNT,LPXIT,R)=0
+6 FOR
SET CNT=$ORDER(^TMP($JOB,PSOTMND,CNT))
if 'CNT!LPXIT
QUIT
SET Y=^(CNT)
Begin DoDot:1
+7 ; display 20 at a time
SET R=R+1
WRITE !,$JUSTIFY(CNT,3)_". "_Y
if (R<20)
QUIT
+8 ; nothing left to display
if '$ORDER(^TMP($JOB,PSOTMND,CNT))
QUIT
+9 KILL DIR,DUOUT
SET DIR(0)="EA"
SET DIR("A")="<ENTER> to see more members, '^' to exit: "
+10 DO ^DIR
SET R=0
if $DATA(DUOUT)
SET LPXIT=1
End DoDot:1
+11 ;
+12 QUIT
+13 ;
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 ; ** NCC REMEDIATION add new reasons 8-11 ** 457/RTW 11 ;;EMERGENCY OVERRIDE NO ANC LAST 7 DAYS
OVRDTXT(RSNCODE) ; function, return text for override
+1 ; no reason code, return null
if '($GET(RSNCODE)>0)
QUIT ""
+2 if $GET(RSNCODE)=1
QUIT "NO WBC IN LAST 7 DAYS"
+3 if $GET(RSNCODE)=2
QUIT "NO VERIFIED WBC"
+4 if $GET(RSNCODE)=3
QUIT "LAST WBC RESULT < 3500"
+5 if $GET(RSNCODE)=4
QUIT "3 SEQ. WBC DECREASE"
+6 if $GET(RSNCODE)=5
QUIT "LAST ANC RESULT < 2000"
+7 if $GET(RSNCODE)=6
QUIT "SEQ. ANC DECREASE"
+8 if $GET(RSNCODE)=7
QUIT "NCCC AUTHORIZED"
+9 if $GET(RSNCODE)=8
QUIT "REGISTER NON-DUTY HR/WEEKEND (MAX 4DAY)"
+10 if $GET(RSNCODE)=9
QUIT "PRESCRIBER APPROVED 4 DAY SUPPLY"
+11 if $GET(RSNCODE)=10
QUIT "MILD NEUTROPENIA PRESCRIBER APPROVED"
+12 ; shouldn't get here, return null
QUIT ""
+13 ;
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 $DATA(^XUSEC("PSOLOCKCLOZ",USRNUM))
+3 ;
XTMPZRO ;set zero node in ^XTMP("PSJ CLOZ")
+1 NEW Y
+2 ; one year (366 days) in the future
SET Y=$$FMADD^XLFDT($$DT^XLFDT,366)
+3 SET $PIECE(^XTMP("PSJ CLOZ",0),U)=Y
SET $PIECE(^XTMP("PSJ CLOZ",0),U,2)=DT
SET $PIECE(^XTMP("PSJ CLOZ",0),U,3)="CLOZAPINE WEEKEND REGISTRATION"
+4 QUIT
+5 ;
