- 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 Jan 18, 2025@03:26:36 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 ;