- 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 Apr 23, 2025@18:28:16 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 ;
