YSCLTST4 ;DALOI/LB/RLM - TRANSMIT RX AND lAB DATA FOR CLOZAPINE ; Nov 27, 2018@17:15
;;5.01;MENTAL HEALTH;**92,122,166,227**;Dec 30, 1994;Build 17
;
; Reference to ^LAB(60 supported by IA #333
; Reference to ^LR7OR1 supported by IA #2503
; Reference to ^DIC supported by DBIA #2051
; Reference to ^DIQ supported by DBIA #2056
; Reference to ^%DTC supported by DBIA #10000
;
CL1 ;(DFN,DAYS) ;
K ^TMP($J,"PSO"),RESULTS,YSCLYWBC,YSCLRANC,YSCLXWBC
Q:'DFN
S:'$G(DAYS) DAYS=90
N ARRAY D LIST^DIC(603.01,,1,"I",,,DFN,"C",,,"ARRAY")
;BEGIN: JCH - YS*5.01*166
N YSCLPSN,PSOCZPTS,PSOERR
;S YSCLPSN=$$GET1^DIQ(55,DFN,53,"I") Q:YSCLPSN="" 0 ; Get current Clozapine number associated with patient's Clozapine registration
D GET55^YSCLTST2(DFN,.YSCLPSN) S YSCLPSN=$G(YSCLPSN(DFN,53)) Q:YSCLPSN="" 0 ; Get current Clozapine number associated with patient's Clozapine registration
D FIND^DIC(603.01,"","","QX",DFN,"","C","I $P($G(^(0)),""^"")=$G(YSCLPSN)","","PSOCZPTS","PSOERR")
S YSCLIEN=$G(PSOCZPTS("DILIST",2,1))
;END: JCH - YS*5.01*166
;S YSCLIEN=$G(ARRAY("DILIST",2,1)),YSCLFRQ="" I YSCLIEN S YSCLFRQ=$$GET1^DIQ(603.01,YSCLIEN,2,"I")
S YSCLFRQ="" I YSCLIEN S YSCLFRQ=$$GET1^DIQ(603.01,YSCLIEN,2,"I")
I $$GET1^DIQ(603.03,1,7,"I")=1 Q "-1^0^0^0^0^0^"_YSCLFRQ
S X1=DT,X2="-"_DAYS D C^%DTC S YSCLSD=X
K ARRAY D LIST^DIC(603.41,",1,","1;2","I",,,,,,,"ARRAY")
F I=1:1 Q:'$D(ARRAY("DILIST",2,I)) S YSCLA=ARRAY("DILIST",2,I) D
. N YSCLTNM,YSCLTTP,YSCLTFR S YSCLTNM=ARRAY("DILIST",1,I) ;$$GET1^DIQ(603.41,YSCLA_",1,",.01,"I")
. S YSCLTTP=ARRAY("DILIST","ID",I,1)
. S YSCLTFR=ARRAY("DILIST","ID",I,2)
. S YSCLTLS(YSCLTTP,YSCLTNM)=YSCLTFR
F I=1:1 Q:'$D(ARRAY("DILIST",1,I)) S YSCLTL=ARRAY("DILIST",1,I) D
. D RR^LR7OR1(DFN,,YSCLSD,DT,,YSCLTL,"L")
. S YSCLSB1="" F S YSCLSB1=$O(^TMP("LRRR",$J,DFN,YSCLSB1)) Q:YSCLSB1="" D
. . S YSCLTDT="" F S YSCLTDT=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT)) Q:YSCLTDT="" D ;YS227
. . . S YSCLTA="" F S YSCLTA=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA)) Q:YSCLTA="" I YSCLTA D
. . . . S RESULTS1=^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA)
. . . . S RESULTS(YSCLTL,YSCLTDT)=$P(RESULTS1,"^",2)
;Find all entries for WBC and sort by inverse date.
S YSCLA="" F S YSCLA=$O(YSCLTLS("W",YSCLA)) Q:'YSCLA S YSCLXWBC(YSCLA)="" D
. S YSCLA1="" F S YSCLA1=$O(RESULTS(YSCLA,YSCLA1)) Q:'YSCLA1 D
. . S YSCLYWBC(YSCLA1)=RESULTS(YSCLA,YSCLA1)*$S(YSCLTLS("W",YSCLA):1000,1:1)
. . S ^TMP($J,"PSO",YSCLA1)=YSCLYWBC(YSCLA1)
S YSCLRWBC=0 F S YSCLRWBC=$O(YSCLYWBC(YSCLRWBC)) Q:YSCLRWBC="" S YSCLRWBC(YSCLRWBC)=YSCLYWBC(YSCLRWBC) D
. ;Match all ANC's and WBC's
. S YSCLMTCH=0 F YSCLA="A","N","S","C" Q:YSCLMTCH S YSCLTPT="" F S YSCLTPT=$O(YSCLTLS(YSCLA,YSCLTPT)) Q:'YSCLTPT D Q:YSCLMTCH
. . I $G(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="A",$D(YSCLRWBC(YSCLRWBC)) S ^TMP($J,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_(RESULTS(YSCLTPT,YSCLRWBC)*$S(YSCLTLS(YSCLA,YSCLTPT):1000,1:1)) Q
. . I $G(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="N",$D(YSCLRWBC(YSCLRWBC)) S YSCLMTCH=1,^TMP($J,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_(YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC)*.01))) Q
. . I $G(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="S",$D(YSCLRWBC(YSCLRWBC)) D Q
. . . S (YSCLSG1,YSCLSGS)="" F S YSCLSGS=$O(YSCLTLS("B",YSCLSGS)) D Q:'YSCLSGS!YSCLMTCH
. . . . I 'YSCLSG1,'YSCLSGS S YSCLSGS="Z",YSCLSG1=1
. . . . I 'YSCLSGS,YSCLSG1 Q
. . . . I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0
. . . . S YSCLMTCH=1,^TMP($J,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_(YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC)*.01)+(RESULTS(YSCLSGS,YSCLRWBC)*.01))) Q
. . I $G(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="C" S YSCLMTCH=1 D
. . . S YSCLSGS="" F S YSCLSGS=$O(YSCLTLS("T",YSCLSGS)) D Q:'YSCLSGS!YSCLMTCH
. . . . I '$G(YSCLSG1),'YSCLSGS S YSCLSGS="Z",YSCLSG1=1
. . . . I 'YSCLSGS,$G(YSCLSG1) Q
. . . . I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0
. . . . S YSCLMTCH=1,^TMP($J,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_((RESULTS(YSCLTPT,YSCLRWBC)*$S(YSCLTLS(YSCLA,YSCLTPT):1000,1:1))+(RESULTS(YSCLSGS,YSCLRWBC))) Q
S YSCLA="A",YSCLTPT="" F S YSCLTPT=$O(YSCLTLS(YSCLA,YSCLTPT)) Q:'YSCLTPT D
. S YSCLRANC="" F S YSCLRNC=$O(RESULTS(YSCLTPT,YSCLRANC)) Q:'YSCLRANC D
. . Q:$D(^TMP($J,"PSO",YSCLRANC))
. . S ^TMP($J,"PSO",YSCLRANC)="^"_(RESULTS(YSCLTPT,YSCLRANC)*$S(YSCLTLS("A",YSCLTPT):1000,1:1))
K FDA,YSCLSGS,Y15,YSCLRWBC,YSCLANC,YSCLYWBC,YSCLFRQ,ZIENS,RESULTS,RESULTS1,YSCLA,YSCLA1,YSCLMTCH,YSCLSB1,YSCLSD
K YSCLTA,YSCLTDT,YSCLTL,YSCLTLS,YSCLTPT,YSCLXWBC,YSCLMULT
Q
;
KILL ;
K FDA,YSCLSGS,Y15,RESULTS,RESULTS1,YSCLA,YSCLA1,YSCLMTCH,YSCLSB1,YSCLSD,YSCLTA,YSCLMULT
K YSCLTDT,YSCLTL,YSCLSG1,YSCLTLS,YSCLTPT,YSCLXWBC
;
ZEOR ;YSCLTST4
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSCLTST4 4770 printed Sep 23, 2025@19:50:02 Page 2
YSCLTST4 ;DALOI/LB/RLM - TRANSMIT RX AND lAB DATA FOR CLOZAPINE ; Nov 27, 2018@17:15
+1 ;;5.01;MENTAL HEALTH;**92,122,166,227**;Dec 30, 1994;Build 17
+2 ;
+3 ; Reference to ^LAB(60 supported by IA #333
+4 ; Reference to ^LR7OR1 supported by IA #2503
+5 ; Reference to ^DIC supported by DBIA #2051
+6 ; Reference to ^DIQ supported by DBIA #2056
+7 ; Reference to ^%DTC supported by DBIA #10000
+8 ;
CL1 ;(DFN,DAYS) ;
+1 KILL ^TMP($JOB,"PSO"),RESULTS,YSCLYWBC,YSCLRANC,YSCLXWBC
+2 if 'DFN
QUIT
+3 if '$GET(DAYS)
SET DAYS=90
+4 NEW ARRAY
DO LIST^DIC(603.01,,1,"I",,,DFN,"C",,,"ARRAY")
+5 ;BEGIN: JCH - YS*5.01*166
+6 NEW YSCLPSN,PSOCZPTS,PSOERR
+7 ;S YSCLPSN=$$GET1^DIQ(55,DFN,53,"I") Q:YSCLPSN="" 0 ; Get current Clozapine number associated with patient's Clozapine registration
+8 ; Get current Clozapine number associated with patient's Clozapine registration
DO GET55^YSCLTST2(DFN,.YSCLPSN)
SET YSCLPSN=$GET(YSCLPSN(DFN,53))
if YSCLPSN=""
QUIT 0
+9 DO FIND^DIC(603.01,"","","QX",DFN,"","C","I $P($G(^(0)),""^"")=$G(YSCLPSN)","","PSOCZPTS","PSOERR")
+10 SET YSCLIEN=$GET(PSOCZPTS("DILIST",2,1))
+11 ;END: JCH - YS*5.01*166
+12 ;S YSCLIEN=$G(ARRAY("DILIST",2,1)),YSCLFRQ="" I YSCLIEN S YSCLFRQ=$$GET1^DIQ(603.01,YSCLIEN,2,"I")
+13 SET YSCLFRQ=""
IF YSCLIEN
SET YSCLFRQ=$$GET1^DIQ(603.01,YSCLIEN,2,"I")
+14 IF $$GET1^DIQ(603.03,1,7,"I")=1
QUIT "-1^0^0^0^0^0^"_YSCLFRQ
+15 SET X1=DT
SET X2="-"_DAYS
DO C^%DTC
SET YSCLSD=X
+16 KILL ARRAY
DO LIST^DIC(603.41,",1,","1;2","I",,,,,,,"ARRAY")
+17 FOR I=1:1
if '$DATA(ARRAY("DILIST",2,I))
QUIT
SET YSCLA=ARRAY("DILIST",2,I)
Begin DoDot:1
+18 ;$$GET1^DIQ(603.41,YSCLA_",1,",.01,"I")
NEW YSCLTNM,YSCLTTP,YSCLTFR
SET YSCLTNM=ARRAY("DILIST",1,I)
+19 SET YSCLTTP=ARRAY("DILIST","ID",I,1)
+20 SET YSCLTFR=ARRAY("DILIST","ID",I,2)
+21 SET YSCLTLS(YSCLTTP,YSCLTNM)=YSCLTFR
End DoDot:1
+22 FOR I=1:1
if '$DATA(ARRAY("DILIST",1,I))
QUIT
SET YSCLTL=ARRAY("DILIST",1,I)
Begin DoDot:1
+23 DO RR^LR7OR1(DFN,,YSCLSD,DT,,YSCLTL,"L")
+24 SET YSCLSB1=""
FOR
SET YSCLSB1=$ORDER(^TMP("LRRR",$JOB,DFN,YSCLSB1))
if YSCLSB1=""
QUIT
Begin DoDot:2
+25 ;YS227
SET YSCLTDT=""
FOR
SET YSCLTDT=$ORDER(^TMP("LRRR",$JOB,DFN,YSCLSB1,YSCLTDT))
if YSCLTDT=""
QUIT
Begin DoDot:3
+26 SET YSCLTA=""
FOR
SET YSCLTA=$ORDER(^TMP("LRRR",$JOB,DFN,YSCLSB1,YSCLTDT,YSCLTA))
if YSCLTA=""
QUIT
IF YSCLTA
Begin DoDot:4
+27 SET RESULTS1=^TMP("LRRR",$JOB,DFN,YSCLSB1,YSCLTDT,YSCLTA)
+28 SET RESULTS(YSCLTL,YSCLTDT)=$PIECE(RESULTS1,"^",2)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+29 ;Find all entries for WBC and sort by inverse date.
+30 SET YSCLA=""
FOR
SET YSCLA=$ORDER(YSCLTLS("W",YSCLA))
if 'YSCLA
QUIT
SET YSCLXWBC(YSCLA)=""
Begin DoDot:1
+31 SET YSCLA1=""
FOR
SET YSCLA1=$ORDER(RESULTS(YSCLA,YSCLA1))
if 'YSCLA1
QUIT
Begin DoDot:2
+32 SET YSCLYWBC(YSCLA1)=RESULTS(YSCLA,YSCLA1)*$SELECT(YSCLTLS("W",YSCLA):1000,1:1)
+33 SET ^TMP($JOB,"PSO",YSCLA1)=YSCLYWBC(YSCLA1)
End DoDot:2
End DoDot:1
+34 SET YSCLRWBC=0
FOR
SET YSCLRWBC=$ORDER(YSCLYWBC(YSCLRWBC))
if YSCLRWBC=""
QUIT
SET YSCLRWBC(YSCLRWBC)=YSCLYWBC(YSCLRWBC)
Begin DoDot:1
+35 ;Match all ANC's and WBC's
+36 SET YSCLMTCH=0
FOR YSCLA="A","N","S","C"
if YSCLMTCH
QUIT
SET YSCLTPT=""
FOR
SET YSCLTPT=$ORDER(YSCLTLS(YSCLA,YSCLTPT))
if 'YSCLTPT
QUIT
Begin DoDot:2
+37 IF $GET(RESULTS(YSCLTPT,YSCLRWBC))
IF YSCLA="A"
IF $DATA(YSCLRWBC(YSCLRWBC))
SET ^TMP($JOB,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_(RESULTS(YSCLTPT,YSCLRWBC)*$SELECT(YSCLTLS(YSCLA,YSCLTPT):1000,1:1))
QUIT
+38 IF $GET(RESULTS(YSCLTPT,YSCLRWBC))
IF YSCLA="N"
IF $DATA(YSCLRWBC(YSCLRWBC))
SET YSCLMTCH=1
SET ^TMP($JOB,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_(YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC)*.01)))
QUIT
+39 IF $GET(RESULTS(YSCLTPT,YSCLRWBC))
IF YSCLA="S"
IF $DATA(YSCLRWBC(YSCLRWBC))
Begin DoDot:3
+40 SET (YSCLSG1,YSCLSGS)=""
FOR
SET YSCLSGS=$ORDER(YSCLTLS("B",YSCLSGS))
Begin DoDot:4
+41 IF 'YSCLSG1
IF 'YSCLSGS
SET YSCLSGS="Z"
SET YSCLSG1=1
+42 IF 'YSCLSGS
IF YSCLSG1
QUIT
+43 IF '$DATA(RESULTS(YSCLSGS,YSCLRWBC))
SET RESULTS(YSCLSGS,YSCLRWBC)=0
+44 SET YSCLMTCH=1
SET ^TMP($JOB,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_(YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC)*.01)+(RESULTS(YSCLSGS,YSCLRWBC)*.01)))
QUIT
End DoDot:4
if 'YSCLSGS!YSCLMTCH
QUIT
End DoDot:3
QUIT
+45 IF $GET(RESULTS(YSCLTPT,YSCLRWBC))
IF YSCLA="C"
SET YSCLMTCH=1
Begin DoDot:3
+46 SET YSCLSGS=""
FOR
SET YSCLSGS=$ORDER(YSCLTLS("T",YSCLSGS))
Begin DoDot:4
+47 IF '$GET(YSCLSG1)
IF 'YSCLSGS
SET YSCLSGS="Z"
SET YSCLSG1=1
+48 IF 'YSCLSGS
IF $GET(YSCLSG1)
QUIT
+49 IF '$DATA(RESULTS(YSCLSGS,YSCLRWBC))
SET RESULTS(YSCLSGS,YSCLRWBC)=0
+50 SET YSCLMTCH=1
SET ^TMP($JOB,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_((RESULTS(YSCLTPT,YSCLRWBC)*$SELECT(YSCLTLS(YSCLA,YSCLTPT):1000,1:1))+(RESULTS(YSCLSGS,YSCLRWBC)))
QUIT
End DoDot:4
if 'YSCLSGS!YSCLMTCH
QUIT
End DoDot:3
End DoDot:2
if YSCLMTCH
QUIT
End DoDot:1
+51 SET YSCLA="A"
SET YSCLTPT=""
FOR
SET YSCLTPT=$ORDER(YSCLTLS(YSCLA,YSCLTPT))
if 'YSCLTPT
QUIT
Begin DoDot:1
+52 SET YSCLRANC=""
FOR
SET YSCLRNC=$ORDER(RESULTS(YSCLTPT,YSCLRANC))
if 'YSCLRANC
QUIT
Begin DoDot:2
+53 if $DATA(^TMP($JOB,"PSO",YSCLRANC))
QUIT
+54 SET ^TMP($JOB,"PSO",YSCLRANC)="^"_(RESULTS(YSCLTPT,YSCLRANC)*$SELECT(YSCLTLS("A",YSCLTPT):1000,1:1))
End DoDot:2
End DoDot:1
+55 KILL FDA,YSCLSGS,Y15,YSCLRWBC,YSCLANC,YSCLYWBC,YSCLFRQ,ZIENS,RESULTS,RESULTS1,YSCLA,YSCLA1,YSCLMTCH,YSCLSB1,YSCLSD
+56 KILL YSCLTA,YSCLTDT,YSCLTL,YSCLTLS,YSCLTPT,YSCLXWBC,YSCLMULT
+57 QUIT
+58 ;
KILL ;
+1 KILL FDA,YSCLSGS,Y15,RESULTS,RESULTS1,YSCLA,YSCLA1,YSCLMTCH,YSCLSB1,YSCLSD,YSCLTA,YSCLMULT
+2 KILL YSCLTDT,YSCLTL,YSCLSG1,YSCLTLS,YSCLTPT,YSCLXWBC
+3 ;
ZEOR ;YSCLTST4
