YSCLSRV3 ;DALOI/RLM,HEC/hrubovcak - Clozapine data server ;16 Oct 2019 19:31:54
;;5.01;MENTAL HEALTH;**74,90,92,154**;Dec 30, 1994;Build 48
; Reference to ^%ZOSF supported by IA #10096
; Reference to ^DPT supported by IA #10035
; Reference to ^PS(55 supported by IA #787
; Reference to ^PSDRUG supported by IA #25
; Reference to ^PSRX supported by IA #780
; Reference to ^VA(200 supported by IA #10060
; Reference to ^XUSEC supported by IA #10076
;
D DT^DICRW
K ^TMP($J,"YSCLXMSG"),^TMP($J,"YSRXPTLST") ; message text & patient list
D ADD2TXT^YSCLSERV("This is a list of all active Clozapine prescriptions.")
D ADD2TXT^YSCLSERV("An asterisk in the first column indicates that the prescription is over")
D ADD2TXT^YSCLSERV("28 days old. The second column is the Patient Name. The third is the")
D ADD2TXT^YSCLSERV("Issue Date. The fourth column is the Prescription Number. The final")
D ADD2TXT^YSCLSERV("column is the CLOZAPINE STATUS indicator.")
;
N C,DFN,DRUGIEN,RXPTR,X,YSLN,YSPT,YSRX,YSV
S YSV("t-28")=$$HTFM^XLFDT($H-28) ; 28 days ago
; ^PS(55,D0,P,D1,0)= (#.01) PRESCRIPTION PROFILE [1P:52]
; loop through CLOZAPINE REGISTRATION NUMBER cross-ref
S DFN=0 F S DFN=$O(^PS(55,"ASAND",DFN)) Q:'DFN I $D(^DPT(DFN,0)),$D(^PS(55,DFN,"SAND")) D
. K YSPT S YSPT(55,"SAND")=$G(^PS(55,DFN,"SAND")) S YSPT(0)=$G(^DPT(DFN,0))
. S RXPTR=0 F S RXPTR=$O(^PS(55,DFN,"P",RXPTR)) Q:'RXPTR K DRUGIEN,YSRX S YSRX=+$G(^PS(55,DFN,"P",RXPTR,0)) I YSRX>0,$D(^PSRX(YSRX,0)) D:'$$RXACTV(YSRX)
.. S YSRX(0)=$G(^PSRX(YSRX,0)),DRUGIEN=+$P(YSRX(0),U,6) Q:'($P($G(^PSDRUG(DRUGIEN,"CLOZ1")),U)="PSOCLO1") ; (#17.5) MONITOR ROUTINE [1F]
.. Q:'$D(^PSDRUG(DRUGIEN,"CLOZ")) ; (#17.2) LAB TEST MONITOR [1P:60]
.. S YSLN=$S(YSV("t-28")>$P(YSRX(0),U,13):"*",1:" ")_U_$P(^DPT($P(YSRX(0),U,2),0),U)_U_$$FMTE^XLFDT($P(YSRX(0),U,13))_U_$P(YSRX(0),U)_U_$P(YSPT(55,"SAND"),U,2)
.. S X=$P(YSPT(0),U)_U_DFN,C=$G(^TMP($J,"YSRXPTLST",X,0))+1,^TMP($J,"YSRXPTLST",X,0)=C,^TMP($J,"YSRXPTLST",X,C)=YSLN ; sort by "patient name^DFN"
; add sorted patient list to the message
S X="" F S X=$O(^TMP($J,"YSRXPTLST",X)) Q:X="" S C=0 F S C=$O(^TMP($J,"YSRXPTLST",X,C)) Q:'C D ADD2TXT^YSCLSERV(^TMP($J,"YSRXPTLST",X,C))
K ^TMP($J,"YSRXPTLST")
G EXIT^YSCLSERV
;
RXACTV(YSRXIEN) ; (#100) STATUS [1S], '0' FOR ACTIVE;
N YSFMERR
Q $$GET1^DIQ(52,YSRXIEN_",",100,"I","YSFMERR")
;
DEMOG ;
S YSCLA=0 F S YSCLA=$O(^YSCL(603.01,"C",YSCLA)) Q:'YSCLA D
. I $D(^PS(55,YSCLA,"SAND")),$P(^PS(55,YSCLA,"SAND"),"^",4)=0 S YSCLC=$G(YSCLC)+1
. I $D(^PS(55,YSCLA,"SAND")),$P(^PS(55,YSCLA,"SAND"),"^",4) S $P(^PS(55,YSCLA,"SAND"),"^",4)=0,YSCLB=$G(YSCLB)+1
D ADD2TXT^YSCLSERV(+$G(YSCLB)_" record"_$S(+$G(YSCLB)=1:"",1:"s")_" reset at ("_YSCLST_") "_YSCLSTN)
D ADD2TXT^YSCLSERV(+$G(YSCLC)_" record"_$S(+$G(YSCLC)=1:"",1:"s")_" not reset at ("_YSCLST_") "_YSCLSTN)
G EXIT^YSCLSERV
Q
LOCK ;Lock out ability to dispense Clozapine
X XMREC Q:XMER<0 S X=XMRG
I X="LOCK DOWN ON" S $P(^YSCL(603.03,1,1),"^",1)=1 D ADD2TXT^YSCLSERV("Clozapine dispensing prohibited at "_YSCLST)
I X="LOCK DOWN OFF" S $P(^YSCL(603.03,1,1),"^",1)=0 D ADD2TXT^YSCLSERV("Clozapine dispensing enabled at "_YSCLST)
G EXIT^YSCLSERV
Q
AUTH ;List authorized Clozapine providers
I YSCLSUB["LIST" D G EXIT^YSCLSERV
. D ADD2TXT^YSCLSERV("The following providers are authorized to override Clozapine lockouts (PSOLOCKCLOZ)")
. S YSCLLN=2
. S YSCLA="" F S YSCLA=$O(^XUSEC("PSOLOCKCLOZ",YSCLA)) Q:YSCLA="" D
. . Q:'$D(^VA(200,YSCLA,0))
. . D ADD2TXT^YSCLSERV($P(^VA(200,YSCLA,0),"^",1)_" "_$S($P(^VA(200,YSCLA,0),"^",7)=1:"Ina",1:"A")_"ctive")
. D ADD2TXT^YSCLSERV(" "),ADD2TXT^YSCLSERV(" "),ADD2TXT^YSCLSERV(" ") ; 3 blank lines
. D ADD2TXT^YSCLSERV("The following providers are authorized to access the Pharmacy Clozapine Manager Menu (PSZ CLOZAPINE)")
. S YSCLA="" F S YSCLA=$O(^XUSEC("PSZ CLOZAPINE",YSCLA)) Q:YSCLA="" D
. . Q:'$D(^VA(200,YSCLA,0))
. . D ADD2TXT^YSCLSERV($P(^VA(200,YSCLA,0),"^",1)_" "_$S($P(^VA(200,YSCLA,0),"^",7)=1:"Ina",1:"A")_"ctive")
. D ADD2TXT^YSCLSERV(" "),ADD2TXT^YSCLSERV(" "),ADD2TXT^YSCLSERV(" ") ; 3 blank lines
. D ADD2TXT^YSCLSERV("The following providers are authorized to prescribe Clozapine (YSCL AUTHORIZED)")
. S YSCLA=0 F S YSCLA=$O(^XUSEC("YSCL AUTHORIZED",YSCLA)) Q:'YSCLA D ;??? Use FileMan lookup on 200
. . S YSCLDEA=$$DEA^XUSER(1,YSCLA),YSCLYN=1,YSPT("ssn")=$P(^VA(200,YSCLA,1),"^",9)
. . D ADD2TXT^YSCLSERV($P($G(^VA(200,YSCLA,0)),"^",1)_" - "_YSPT("ssn")_" - "_$S(YSCLDEA="":"*NONE*",1:YSCLDEA)_" - "_$S(YSCLYN=1:"Yes",1:"NO"))
;Holders of YSCL AUTHORIZED key
;
;
D ADD2TXT^YSCLSERV("Clinician Authorization Results at "_YSCLST)
K ^TMP("DIERR",$J)
F X XMREC Q:XMER<0 S X=XMRG X ^%ZOSF("UPPERCASE") S X=Y D
. S YSPT("ssn")=$P(X,"^",1),YSCLDEA=$P(X,"^",2),YSCLYN=$P(X,"^",3),YSCLDUZ="",YSCLDEA1="",YSCLIEN=""
. I YSCLLN=""!("YESNO"'[YSCLYN) D ADD2TXT^YSCLSERV("Clinician Authorization instructions invalid ("_YSCLYN_") at "_YSCLST)
. S YSCLYN=$S(YSCLYN="YES":1,1:0)
. I '$D(^VA(200,"BS5",YSPT("ssn"))) D ADD2TXT^YSCLSERV("Clinician ("_YSPT("ssn")_") does not exist at "_YSCLST) Q
. I $D(^VA(200,"BS5",YSPT("ssn"))) S YSCLAA="" F S YSCLAA=$O(^VA(200,"BS5",YSPT("ssn"),YSCLAA)) Q:YSCLAA="" I $$DEA^XUSER(1,YSCLAA)=YSCLDEA S YSCLDUZ=YSCLAA Q
. I YSCLDUZ="" D ADD2TXT^YSCLSERV("Clinician ("_YSPT("ssn")_") with DEA# "_YSCLDEA_" does not exist at "_YSCLST) Q
. S YSCLDEA1=$$DEA^XUSER(1,YSCLDUZ)
. I YSCLDEA1="" D ADD2TXT^YSCLSERV("Clinician with DEA# "_YSCLDEA_" does not exist at "_YSCLST) Q
. I YSCLDEA'=YSCLDEA1 D ADD2TXT^YSCLSERV("Clinician SSN ("_YSPT("ssn")_") - DEA ("_YSCLDEA_") mismatch at "_YSCLST) Q
. D OWNSKEY^XUSRB(.RET,"YSCL AUTHORIZED",YSCLDUZ)
. I RET(0),YSCLYN D ADD2TXT^YSCLSERV("Clinician ("_YSPT("ssn")_") already authorized at "_YSCLST) Q
. I 'RET(0),'YSCLYN D ADD2TXT^YSCLSERV("Clinician ("_YSPT("ssn")_") not authorized at "_YSCLST) Q
. I 'RET(0),YSCLYN S YSCLDUZ(0)=DUZ,DUZ(0)="@" D S DUZ(0)=YSCLDUZ(0)
. . S YSCLFDA(200,"?1,",.01)="`"_YSCLDUZ
. . S YSCLFDA(200.051,"+2,?1,",.01)="YSCL AUTHORIZED" D UPDATE^DIE("E","YSCLFDA",,"YSCLERR")
. . I $D(YSCLERR) D ADD2TXT^YSCLSERV("Clinician SSN "_YSPT("ssn")_" authorization failed at "_YSCLST) Q
. . I '$D(YSCLERR) D ADD2TXT^YSCLSERV("Clinician SSN "_YSPT("ssn")_" authorization set to "_$S(YSCLYN=1:"Yes",1:"No")_" at "_YSCLST) Q
. I RET(0),'YSCLYN S YSCLDUZ(0)=DUZ,DUZ(0)="@" D S DUZ(0)=YSCLDUZ(0)
. . S DA=$$FIND1^DIC(200.051,","_YSCLDUZ_",","A","YSCL AUTHORIZE")
. . I DA<1 D ADD2TXT^YSCLSERV("Clinician SSN "_YSPT("ssn")_" authorization removal failed at "_YSCLST) Q
. . S DA(1)=YSCLDUZ,DIK="^VA(200,"_DA(1)_",51," D ^DIK
. . D ADD2TXT^YSCLSERV("Clinician SSN "_YSPT("ssn")_" authorization removed at "_YSCLST) Q
G EXIT^YSCLSERV
Q
;
LKUP ; lookup patients in file #603.01
K ^TMP($J,"YSCLXMSG") ; message text
N X,YSFMERR,YSFMRSLT,YSPT,YSXMINST,YSXMY,YSXMZ
S X=$$SITE^VASITE
D ADD2TXT^YSCLSERV("Site "_$P(X,U,2)_" ("_$P(X,U,3)_") inquiry to file #603.01"),ADD2TXT^YSCLSERV(" ")
F X XMREC Q:XMER<0 D:XMRG]"" ; process list of SSNs
. K YSFMERR,YSPT,YSFMRSLT
. S YSPT("ssn")=$TR(XMRG," -","") ; strip spaces and hyphens
. I '(YSPT("ssn")?9N) D ADD2TXT^YSCLSERV("Error: "_XMRG_" is not a valid SSN."),ADD2TXT^YSCLSERV(" ") Q
. D LIST^DIC(2,,".01;.09",,,,YSPT("ssn"),"SSN",,,"YSFMRSLT","YSFMERR")
. S YSPT("name")=$G(YSFMRSLT("DILIST","ID",1,.01))
. I '$L(YSPT("name")) D Q
.. D ADD2TXT^YSCLSERV("Error: SSN "_YSPT("ssn")_" not found in the PATIENT file (#2)"),ADD2TXT^YSCLSERV(" ")
. K YSFMERR,YSFMRSLT
. D LIST^DIC(603.01,,".01E;1E;2E;3E",,,,YSPT("name"),"C",,,"YSFMRSLT","YSFMERR")
. I '$G(YSFMRSLT("DILIST",2,1)) D Q
.. D ADD2TXT^YSCLSERV("SSN "_YSPT("ssn")_" not found in file #603.01"),ADD2TXT^YSCLSERV(" ")
. ; put each entry in the message
. N FLD,YSIEN
. S YSIEN=0 F S YSIEN=$O(YSFMRSLT("DILIST","ID",YSIEN)) Q:'YSIEN D
.. D ADD2TXT^YSCLSERV("IEN in file #603.01: "_YSFMRSLT("DILIST",2,YSIEN)_" for SSN "_YSPT("ssn"))
.. ; send only fields with data
.. S FLD=0 F S FLD=$O(YSFMRSLT("DILIST","ID",YSIEN,FLD)) Q:'FLD D:$L(YSFMRSLT("DILIST","ID",YSIEN,FLD))
... N YSERR,YSLBL
... D FIELD^DID(603.01,FLD,"N","LABEL","YSLBL","YSERR") Q:'$L($G(YSLBL("LABEL")))
... D ADD2TXT^YSCLSERV(YSLBL("LABEL")_": "_YSFMRSLT("DILIST","ID",YSIEN,FLD))
.. ; blank line after each entry
.. D ADD2TXT^YSCLSERV(" ")
; done with lookups
D ADD2TXT^YSCLSERV($J("* END OF REPORT *",35))
S X=$$GET1^DIQ(603.03,1,3,"I") ; debug?
S YSXMSUB=$S(X:"DEBUG ",1:"")_"NCCC PATIENT LOOKUP "_$$FMTE^XLFDT($$NOW^XLFDT)
S X=$$GET1^DIQ(8989.3,1,501,"I") ; production?
S:X YSXMY("G.CLOZAPINE ROLL-UP@DOMAIN.EXT")=""
S:'X YSXMY("G.CLOZAPINE ROLL-UP")=""
S YSXMINST("FROM")="CLOZAPINE SERVER"
; Mail the report
D SENDMSG^XMXAPI(DUZ,YSXMSUB,$NA(^TMP($J,"YSCLXMSG")),.YSXMY,.YSXMINST,.YSXMZ)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSCLSRV3 9030 printed Sep 23, 2025@19:49:57 Page 2
YSCLSRV3 ;DALOI/RLM,HEC/hrubovcak - Clozapine data server ;16 Oct 2019 19:31:54
+1 ;;5.01;MENTAL HEALTH;**74,90,92,154**;Dec 30, 1994;Build 48
+2 ; Reference to ^%ZOSF supported by IA #10096
+3 ; Reference to ^DPT supported by IA #10035
+4 ; Reference to ^PS(55 supported by IA #787
+5 ; Reference to ^PSDRUG supported by IA #25
+6 ; Reference to ^PSRX supported by IA #780
+7 ; Reference to ^VA(200 supported by IA #10060
+8 ; Reference to ^XUSEC supported by IA #10076
+9 ;
+10 DO DT^DICRW
+11 ; message text & patient list
KILL ^TMP($JOB,"YSCLXMSG"),^TMP($JOB,"YSRXPTLST")
+12 DO ADD2TXT^YSCLSERV("This is a list of all active Clozapine prescriptions.")
+13 DO ADD2TXT^YSCLSERV("An asterisk in the first column indicates that the prescription is over")
+14 DO ADD2TXT^YSCLSERV("28 days old. The second column is the Patient Name. The third is the")
+15 DO ADD2TXT^YSCLSERV("Issue Date. The fourth column is the Prescription Number. The final")
+16 DO ADD2TXT^YSCLSERV("column is the CLOZAPINE STATUS indicator.")
+17 ;
+18 NEW C,DFN,DRUGIEN,RXPTR,X,YSLN,YSPT,YSRX,YSV
+19 ; 28 days ago
SET YSV("t-28")=$$HTFM^XLFDT($HOROLOG-28)
+20 ; ^PS(55,D0,P,D1,0)= (#.01) PRESCRIPTION PROFILE [1P:52]
+21 ; loop through CLOZAPINE REGISTRATION NUMBER cross-ref
+22 SET DFN=0
FOR
SET DFN=$ORDER(^PS(55,"ASAND",DFN))
if 'DFN
QUIT
IF $DATA(^DPT(DFN,0))
IF $DATA(^PS(55,DFN,"SAND"))
Begin DoDot:1
+23 KILL YSPT
SET YSPT(55,"SAND")=$GET(^PS(55,DFN,"SAND"))
SET YSPT(0)=$GET(^DPT(DFN,0))
+24 SET RXPTR=0
FOR
SET RXPTR=$ORDER(^PS(55,DFN,"P",RXPTR))
if 'RXPTR
QUIT
KILL DRUGIEN,YSRX
SET YSRX=+$GET(^PS(55,DFN,"P",RXPTR,0))
IF YSRX>0
IF $DATA(^PSRX(YSRX,0))
if '$$RXACTV(YSRX)
Begin DoDot:2
+25 ; (#17.5) MONITOR ROUTINE [1F]
SET YSRX(0)=$GET(^PSRX(YSRX,0))
SET DRUGIEN=+$PIECE(YSRX(0),U,6)
if '($PIECE($GET(^PSDRUG(DRUGIEN,"CLOZ1")),U)="PSOCLO1")
QUIT
+26 ; (#17.2) LAB TEST MONITOR [1P:60]
if '$DATA(^PSDRUG(DRUGIEN,"CLOZ"))
QUIT
+27 SET YSLN=$SELECT(YSV("t-28")>$PIECE(YSRX(0),U,13):"*",1:" ")_U_$PIECE(^DPT($PIECE(YSRX(0),U,2),0),U)_U_$$FMTE^XLFDT($PIECE(YSRX(0),U,13))_U_$PIECE(YSRX(0),U)_U_$PIECE(YSPT(55,"SAND"),U,2)
+28 ; sort by "patient name^DFN"
SET X=$PIECE(YSPT(0),U)_U_DFN
SET C=$GET(^TMP($JOB,"YSRXPTLST",X,0))+1
SET ^TMP($JOB,"YSRXPTLST",X,0)=C
SET ^TMP($JOB,"YSRXPTLST",X,C)=YSLN
End DoDot:2
End DoDot:1
+29 ; add sorted patient list to the message
+30 SET X=""
FOR
SET X=$ORDER(^TMP($JOB,"YSRXPTLST",X))
if X=""
QUIT
SET C=0
FOR
SET C=$ORDER(^TMP($JOB,"YSRXPTLST",X,C))
if 'C
QUIT
DO ADD2TXT^YSCLSERV(^TMP($JOB,"YSRXPTLST",X,C))
+31 KILL ^TMP($JOB,"YSRXPTLST")
+32 GOTO EXIT^YSCLSERV
+33 ;
RXACTV(YSRXIEN) ; (#100) STATUS [1S], '0' FOR ACTIVE;
+1 NEW YSFMERR
+2 QUIT $$GET1^DIQ(52,YSRXIEN_",",100,"I","YSFMERR")
+3 ;
DEMOG ;
+1 SET YSCLA=0
FOR
SET YSCLA=$ORDER(^YSCL(603.01,"C",YSCLA))
if 'YSCLA
QUIT
Begin DoDot:1
+2 IF $DATA(^PS(55,YSCLA,"SAND"))
IF $PIECE(^PS(55,YSCLA,"SAND"),"^",4)=0
SET YSCLC=$GET(YSCLC)+1
+3 IF $DATA(^PS(55,YSCLA,"SAND"))
IF $PIECE(^PS(55,YSCLA,"SAND"),"^",4)
SET $PIECE(^PS(55,YSCLA,"SAND"),"^",4)=0
SET YSCLB=$GET(YSCLB)+1
End DoDot:1
+4 DO ADD2TXT^YSCLSERV(+$GET(YSCLB)_" record"_$SELECT(+$GET(YSCLB)=1:"",1:"s")_" reset at ("_YSCLST_") "_YSCLSTN)
+5 DO ADD2TXT^YSCLSERV(+$GET(YSCLC)_" record"_$SELECT(+$GET(YSCLC)=1:"",1:"s")_" not reset at ("_YSCLST_") "_YSCLSTN)
+6 GOTO EXIT^YSCLSERV
+7 QUIT
LOCK ;Lock out ability to dispense Clozapine
+1 XECUTE XMREC
if XMER<0
QUIT
SET X=XMRG
+2 IF X="LOCK DOWN ON"
SET $PIECE(^YSCL(603.03,1,1),"^",1)=1
DO ADD2TXT^YSCLSERV("Clozapine dispensing prohibited at "_YSCLST)
+3 IF X="LOCK DOWN OFF"
SET $PIECE(^YSCL(603.03,1,1),"^",1)=0
DO ADD2TXT^YSCLSERV("Clozapine dispensing enabled at "_YSCLST)
+4 GOTO EXIT^YSCLSERV
+5 QUIT
AUTH ;List authorized Clozapine providers
+1 IF YSCLSUB["LIST"
Begin DoDot:1
+2 DO ADD2TXT^YSCLSERV("The following providers are authorized to override Clozapine lockouts (PSOLOCKCLOZ)")
+3 SET YSCLLN=2
+4 SET YSCLA=""
FOR
SET YSCLA=$ORDER(^XUSEC("PSOLOCKCLOZ",YSCLA))
if YSCLA=""
QUIT
Begin DoDot:2
+5 if '$DATA(^VA(200,YSCLA,0))
QUIT
+6 DO ADD2TXT^YSCLSERV($PIECE(^VA(200,YSCLA,0),"^",1)_" "_$SELECT($PIECE(^VA(200,YSCLA,0),"^",7)=1:"Ina",1:"A")_"ctive")
End DoDot:2
+7 ; 3 blank lines
DO ADD2TXT^YSCLSERV(" ")
DO ADD2TXT^YSCLSERV(" ")
DO ADD2TXT^YSCLSERV(" ")
+8 DO ADD2TXT^YSCLSERV("The following providers are authorized to access the Pharmacy Clozapine Manager Menu (PSZ CLOZAPINE)")
+9 SET YSCLA=""
FOR
SET YSCLA=$ORDER(^XUSEC("PSZ CLOZAPINE",YSCLA))
if YSCLA=""
QUIT
Begin DoDot:2
+10 if '$DATA(^VA(200,YSCLA,0))
QUIT
+11 DO ADD2TXT^YSCLSERV($PIECE(^VA(200,YSCLA,0),"^",1)_" "_$SELECT($PIECE(^VA(200,YSCLA,0),"^",7)=1:"Ina",1:"A")_"ctive")
End DoDot:2
+12 ; 3 blank lines
DO ADD2TXT^YSCLSERV(" ")
DO ADD2TXT^YSCLSERV(" ")
DO ADD2TXT^YSCLSERV(" ")
+13 DO ADD2TXT^YSCLSERV("The following providers are authorized to prescribe Clozapine (YSCL AUTHORIZED)")
+14 ;??? Use FileMan lookup on 200
SET YSCLA=0
FOR
SET YSCLA=$ORDER(^XUSEC("YSCL AUTHORIZED",YSCLA))
if 'YSCLA
QUIT
Begin DoDot:2
+15 SET YSCLDEA=$$DEA^XUSER(1,YSCLA)
SET YSCLYN=1
SET YSPT("ssn")=$PIECE(^VA(200,YSCLA,1),"^",9)
+16 DO ADD2TXT^YSCLSERV($PIECE($GET(^VA(200,YSCLA,0)),"^",1)_" - "_YSPT("ssn")_" - "_$SELECT(YSCLDEA="":"*NONE*",1:YSCLDEA)_" - "_$SELECT(YSCLYN=1:"Yes",1:"NO"))
End DoDot:2
End DoDot:1
GOTO EXIT^YSCLSERV
+17 ;Holders of YSCL AUTHORIZED key
+18 ;
+19 ;
+20 DO ADD2TXT^YSCLSERV("Clinician Authorization Results at "_YSCLST)
+21 KILL ^TMP("DIERR",$JOB)
+22 FOR
XECUTE XMREC
if XMER<0
QUIT
SET X=XMRG
XECUTE ^%ZOSF("UPPERCASE")
SET X=Y
Begin DoDot:1
+23 SET YSPT("ssn")=$PIECE(X,"^",1)
SET YSCLDEA=$PIECE(X,"^",2)
SET YSCLYN=$PIECE(X,"^",3)
SET YSCLDUZ=""
SET YSCLDEA1=""
SET YSCLIEN=""
+24 IF YSCLLN=""!("YESNO"'[YSCLYN)
DO ADD2TXT^YSCLSERV("Clinician Authorization instructions invalid ("_YSCLYN_") at "_YSCLST)
+25 SET YSCLYN=$SELECT(YSCLYN="YES":1,1:0)
+26 IF '$DATA(^VA(200,"BS5",YSPT("ssn")))
DO ADD2TXT^YSCLSERV("Clinician ("_YSPT("ssn")_") does not exist at "_YSCLST)
QUIT
+27 IF $DATA(^VA(200,"BS5",YSPT("ssn")))
SET YSCLAA=""
FOR
SET YSCLAA=$ORDER(^VA(200,"BS5",YSPT("ssn"),YSCLAA))
if YSCLAA=""
QUIT
IF $$DEA^XUSER(1,YSCLAA)=YSCLDEA
SET YSCLDUZ=YSCLAA
QUIT
+28 IF YSCLDUZ=""
DO ADD2TXT^YSCLSERV("Clinician ("_YSPT("ssn")_") with DEA# "_YSCLDEA_" does not exist at "_YSCLST)
QUIT
+29 SET YSCLDEA1=$$DEA^XUSER(1,YSCLDUZ)
+30 IF YSCLDEA1=""
DO ADD2TXT^YSCLSERV("Clinician with DEA# "_YSCLDEA_" does not exist at "_YSCLST)
QUIT
+31 IF YSCLDEA'=YSCLDEA1
DO ADD2TXT^YSCLSERV("Clinician SSN ("_YSPT("ssn")_") - DEA ("_YSCLDEA_") mismatch at "_YSCLST)
QUIT
+32 DO OWNSKEY^XUSRB(.RET,"YSCL AUTHORIZED",YSCLDUZ)
+33 IF RET(0)
IF YSCLYN
DO ADD2TXT^YSCLSERV("Clinician ("_YSPT("ssn")_") already authorized at "_YSCLST)
QUIT
+34 IF 'RET(0)
IF 'YSCLYN
DO ADD2TXT^YSCLSERV("Clinician ("_YSPT("ssn")_") not authorized at "_YSCLST)
QUIT
+35 IF 'RET(0)
IF YSCLYN
SET YSCLDUZ(0)=DUZ
SET DUZ(0)="@"
Begin DoDot:2
+36 SET YSCLFDA(200,"?1,",.01)="`"_YSCLDUZ
+37 SET YSCLFDA(200.051,"+2,?1,",.01)="YSCL AUTHORIZED"
DO UPDATE^DIE("E","YSCLFDA",,"YSCLERR")
+38 IF $DATA(YSCLERR)
DO ADD2TXT^YSCLSERV("Clinician SSN "_YSPT("ssn")_" authorization failed at "_YSCLST)
QUIT
+39 IF '$DATA(YSCLERR)
DO ADD2TXT^YSCLSERV("Clinician SSN "_YSPT("ssn")_" authorization set to "_$SELECT(YSCLYN=1:"Yes",1:"No")_" at "_YSCLST)
QUIT
End DoDot:2
SET DUZ(0)=YSCLDUZ(0)
+40 IF RET(0)
IF 'YSCLYN
SET YSCLDUZ(0)=DUZ
SET DUZ(0)="@"
Begin DoDot:2
+41 SET DA=$$FIND1^DIC(200.051,","_YSCLDUZ_",","A","YSCL AUTHORIZE")
+42 IF DA<1
DO ADD2TXT^YSCLSERV("Clinician SSN "_YSPT("ssn")_" authorization removal failed at "_YSCLST)
QUIT
+43 SET DA(1)=YSCLDUZ
SET DIK="^VA(200,"_DA(1)_",51,"
DO ^DIK
+44 DO ADD2TXT^YSCLSERV("Clinician SSN "_YSPT("ssn")_" authorization removed at "_YSCLST)
QUIT
End DoDot:2
SET DUZ(0)=YSCLDUZ(0)
End DoDot:1
+45 GOTO EXIT^YSCLSERV
+46 QUIT
+47 ;
LKUP ; lookup patients in file #603.01
+1 ; message text
KILL ^TMP($JOB,"YSCLXMSG")
+2 NEW X,YSFMERR,YSFMRSLT,YSPT,YSXMINST,YSXMY,YSXMZ
+3 SET X=$$SITE^VASITE
+4 DO ADD2TXT^YSCLSERV("Site "_$PIECE(X,U,2)_" ("_$PIECE(X,U,3)_") inquiry to file #603.01")
DO ADD2TXT^YSCLSERV(" ")
+5 ; process list of SSNs
FOR
XECUTE XMREC
if XMER<0
QUIT
if XMRG]""
Begin DoDot:1
+6 KILL YSFMERR,YSPT,YSFMRSLT
+7 ; strip spaces and hyphens
SET YSPT("ssn")=$TRANSLATE(XMRG," -","")
+8 IF '(YSPT("ssn")?9N)
DO ADD2TXT^YSCLSERV("Error: "_XMRG_" is not a valid SSN.")
DO ADD2TXT^YSCLSERV(" ")
QUIT
+9 DO LIST^DIC(2,,".01;.09",,,,YSPT("ssn"),"SSN",,,"YSFMRSLT","YSFMERR")
+10 SET YSPT("name")=$GET(YSFMRSLT("DILIST","ID",1,.01))
+11 IF '$LENGTH(YSPT("name"))
Begin DoDot:2
+12 DO ADD2TXT^YSCLSERV("Error: SSN "_YSPT("ssn")_" not found in the PATIENT file (#2)")
DO ADD2TXT^YSCLSERV(" ")
End DoDot:2
QUIT
+13 KILL YSFMERR,YSFMRSLT
+14 DO LIST^DIC(603.01,,".01E;1E;2E;3E",,,,YSPT("name"),"C",,,"YSFMRSLT","YSFMERR")
+15 IF '$GET(YSFMRSLT("DILIST",2,1))
Begin DoDot:2
+16 DO ADD2TXT^YSCLSERV("SSN "_YSPT("ssn")_" not found in file #603.01")
DO ADD2TXT^YSCLSERV(" ")
End DoDot:2
QUIT
+17 ; put each entry in the message
+18 NEW FLD,YSIEN
+19 SET YSIEN=0
FOR
SET YSIEN=$ORDER(YSFMRSLT("DILIST","ID",YSIEN))
if 'YSIEN
QUIT
Begin DoDot:2
+20 DO ADD2TXT^YSCLSERV("IEN in file #603.01: "_YSFMRSLT("DILIST",2,YSIEN)_" for SSN "_YSPT("ssn"))
+21 ; send only fields with data
+22 SET FLD=0
FOR
SET FLD=$ORDER(YSFMRSLT("DILIST","ID",YSIEN,FLD))
if 'FLD
QUIT
if $LENGTH(YSFMRSLT("DILIST","ID",YSIEN,FLD))
Begin DoDot:3
+23 NEW YSERR,YSLBL
+24 DO FIELD^DID(603.01,FLD,"N","LABEL","YSLBL","YSERR")
if '$LENGTH($GET(YSLBL("LABEL")))
QUIT
+25 DO ADD2TXT^YSCLSERV(YSLBL("LABEL")_": "_YSFMRSLT("DILIST","ID",YSIEN,FLD))
End DoDot:3
+26 ; blank line after each entry
+27 DO ADD2TXT^YSCLSERV(" ")
End DoDot:2
End DoDot:1
+28 ; done with lookups
+29 DO ADD2TXT^YSCLSERV($JUSTIFY("* END OF REPORT *",35))
+30 ; debug?
SET X=$$GET1^DIQ(603.03,1,3,"I")
+31 SET YSXMSUB=$SELECT(X:"DEBUG ",1:"")_"NCCC PATIENT LOOKUP "_$$FMTE^XLFDT($$NOW^XLFDT)
+32 ; production?
SET X=$$GET1^DIQ(8989.3,1,501,"I")
+33 if X
SET YSXMY("G.CLOZAPINE ROLL-UP@DOMAIN.EXT")=""
+34 if 'X
SET YSXMY("G.CLOZAPINE ROLL-UP")=""
+35 SET YSXMINST("FROM")="CLOZAPINE SERVER"
+36 ; Mail the report
+37 DO SENDMSG^XMXAPI(DUZ,YSXMSUB,$NAME(^TMP($JOB,"YSCLXMSG")),.YSXMY,.YSXMINST,.YSXMZ)
+38 QUIT
+39 ;
