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

PSOCLOU.m

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