YSCLTST1 ;DALOI/LB/RLM-COLLECT RX AND LAB DATA FOR CLOZAPINE ;18 Feb 93
;;5.01;MENTAL HEALTH;**18,22,25,26,47,61,69,74,90**;Dec 30, 1994;Build 18
; Reference to ^DPT supported by IA #10035
; Reference to ^LR supported by IA #2657
; Reference to ^LAB supported by IA #333
; Reference to ^PS(52.52 supported by IA #782
; Reference to ^PS(55 supported by IA #787
; Reference to ^PS(59 supported by IA #783
; Reference to ^PSRX supported by IA #780
; Reference to ^VA(200 supported by IA #10060
CHECK ;for data to send
S YSCLT=0,YSCLWBC=0
S $P(YSSTOP,",",3)=3 Q:$$S^%ZTLOAD
K PNM,SEX,DOB,AGE,SSN D DEM^VADPT I 'VAERR S PNM=VADM(1),SEX=$P(VADM(5),U),DOB=$P(VADM(3),U),AGE=VADM(4),SSN=$P(VADM(2),U)
I YSCLLD=0,$P($G(^PS(55,DFN,"SAND")),"^",2)="P" Q ;no transmit for pretreatment
I YSCLLD,YSCLLD<YSCLM56 S $P(^PS(55,DFN,"SAND"),"^",2)="D" ;force discontinued
I YSCLLD,YSCLLD<YSCLM180 Q ;Don't report if over 6 months old.
S YSCL=$O(YSCLA("")) I 'YSCL D LAB S YSCLT=1 Q ;get latest WBC results even if no script.
S YSCL1=-$O(YSCLA(YSCL,"")) I 'YSCL1 D LAB S YSCLT=1 Q ;get latest WBC results even if no script.
S YSCLT=1,YSCLRX=$G(^PSRX(YSCL1,0)),YSCLRX2=$G(^PSRX(YSCL1,2)) ;we've got something
S YSCLGL=$S($D(^PS(59)):"^PS",1:"^DIC")
;YSCLGL is used to indirectly hold the global reference for file 59. This is necessary due to changes in the file location. The $select may be expanded to cover future moves. DBIA 273-B
S YSCLD=+$P($G(^PSRX(YSCL1,2)),"^",9),YSCLD=$G(@YSCLGL@(59,YSCLD,"SAND")),$P(YSCLX,"^",10)=$P(YSCLD,"^"),$P(YSCLX,"^",12)=$P(YSCLD,"^",2)
;site DEA# (p10), site pointer (p12)
I YSCLLD<YSCLM7 S YSCLWBC="",$P(^PS(55,DFN,"SAND"),"^",2)="H",$P(YSCLX,"^",5)="H" ;Place on hold status
;here if active
I $P(YSCLX,"^",5)'="H" S $P(^PS(55,DFN,"SAND"),"^",2)="A",$P(YSCLX,"^",5)="A" ;force active
S $P(YSCLX,"^",13)=1,$P(YSCLX,"^",9)=$P(YSCLRX,"^",13),YSCLD1=$G(^PSRX(YSCL1,"SAND")),$P(YSCLX,"^",8)=+YSCLD1
;status(p5),dosage(p8),rx count(p13),issue date(p9)
S YSCLLO=$O(^PS(52.52,"A",YSCL1,0)) I YSCLLO S YSCLLO=^PS(52.52,YSCLLO,0),$P(YSCLX,"^",14)=$P(YSCLLO,"^",5),YSCLLO=+$P(YSCLLO,"^",4),$P(YSCLX,"^",15)=$P(^VA(200,YSCLLO,0),"^")
;lockout reason (p14), approving official (p15)
S $P(YSSTOP,",",4)=4 Q:$$S^%ZTLOAD
S YSCLPHY=$G(^VA(200,+$P(YSCLRX,"^",4),0)),$P(YSCLX,"^",7)=$P($G(^VA(200,+$P(YSCLRX,"^",4),"PS")),"^",2),YSCLPHY=$P(YSCLPHY,"^")
S $P(YSCLX,"^",4)=1000*$P(YSCLD1,"^",2),$P(YSCLX,"^",3)=$P(YSCLD1,"^",3) I $P(YSCLD1,"^",2)]"",$P(YSCLD1,"^",3)'>YSCLED,$P(YSCLD1,"^",3)'<YSCLM7 S YSCLWBC=1
;wbc(p4),date(p3)
S YSCL2=-$O(YSCLA(YSCL,-YSCL1)) I YSCL2,+$P($G(^PSRX(YSCL2,0)),"^",6)'=$P(YSCLRX,"^",6) S YSCL2=$G(^PSRX(YSCL2,"SAND")),$P(YSCLX,"^",13)=2 I $P(YSCL2,"^")'=$P(YSCLX,"^",8) S $P(YSCLX,"^",8)=$P(YSCLX,"^",8)+YSCL2
; add if prescription on same day for different drug and different dose
S $P(YSCLX,"^",21)=$P(YSCLRX2,"^",7) ;Add NDC to string
LAB ;get most recent
S $P(YSSTOP,",",5)=5 Q:$$S^%ZTLOAD
S YSCLLDT="",J=9999998-YSCLED,K=9999998-YSCLM7 I $P(YSCLX,"^",9) S J=9999998-$P(YSCLX,"^",9)
S YSCLR=$$CL^YSCLTST2(DFN) D ;Set 3,4,17,19,20,22,23
. S $P(YSCLX,"^",3)=$P(YSCLR,"^",6) ;WBC Date
. S $P(YSCLX,"^",4)=$P(YSCLR,"^",2) ;WBC Results
. ;S $P(YSCLX,"^",17)=$P(YSCLR,"^",6) ;WBC test count ???
. S $P(YSCLX,"^",19)=$P(YSCLR,"^",6) ;ANC Date
. S $P(YSCLX,"^",20)=$P(YSCLR,"^",4) ;ANC Results
. S $P(YSCLX,"^",22)=$P(YSCLR,"^",3) ;WBC Name
. S $P(YSCLX,"^",23)=$P(YSCLR,"^",5) ;ANC Name
Q
LOAD ;
S $P(YSSTOP,",",6)=6 Q:$$S^%ZTLOAD
I YSCLWBC="",YSCLLD<YSCLM28 Q
; don't send for pretest or older that 28 days
S YSCLNSTE=$P($G(^PS(59,+$P($G(^PSRX(YSCL1,2)),"^",9),0)),"^",6)
S YSCLNST1=$P($$SITE^VASITE,"^",2),YSCLNSTE=$P($$SITE^VASITE,"^",3)
S YSCLLN=YSCLLN+1,$P(YSCLX,"^",18)=YSCLRET,^TMP($J,YSCLLN,0)=YSCLX,YSCLLN=YSCLLN+1,^TMP($J,YSCLLN,0)=YSCLPHY_"^"_YSCLDEMO_"^"_YSCLNSTE_"^"_YSCLNST1
;site number and name
;S YSCLLLN=YSCLLLN+1,^TMP("YSCL",$J,YSCLLLN,0)=$P(^DPT(DFN,0),"^",9)_" "_$P(^(0),"^")_" "_$S($P(YSCLX,"^",13)="":"NO ",1:" ")_"RX "_$S(YSCLWBC="":"NO ",1:" ")_"LAB" Q
S YSCLLLN=YSCLLLN+1,^TMP("YSCL",$J,YSCLLLN,0)=$P(^DPT(DFN,0),"^",9)_" "_$P(^(0),"^")_" (R) "_$S($P(YSCLX,"^",13)="":"NO RX ",1:$$FMTE^XLFDT($P(YSCLX,"^",9),"D"))_" (W) "
S ^TMP("YSCL",$J,YSCLLLN,0)=^TMP("YSCL",$J,YSCLLLN,0)_$S($P(YSCLX,"^",3)="":"NO WBC ",1:$$FMTE^XLFDT($P(YSCLX,"^",3),"D"))_" (N) "_$S($P(YSCLX,"^",20)="":"NO NEUT ",1:$$FMTE^XLFDT($P(YSCLX,"^",19),"D")) Q
;9the piece for issue date, 16th piece for WBC date ;RLM 06/16/05
Q
ZEOR ;YSCLTST1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSCLTST1 4612 printed Dec 13, 2024@02:13:53 Page 2
YSCLTST1 ;DALOI/LB/RLM-COLLECT RX AND LAB DATA FOR CLOZAPINE ;18 Feb 93
+1 ;;5.01;MENTAL HEALTH;**18,22,25,26,47,61,69,74,90**;Dec 30, 1994;Build 18
+2 ; Reference to ^DPT supported by IA #10035
+3 ; Reference to ^LR supported by IA #2657
+4 ; Reference to ^LAB supported by IA #333
+5 ; Reference to ^PS(52.52 supported by IA #782
+6 ; Reference to ^PS(55 supported by IA #787
+7 ; Reference to ^PS(59 supported by IA #783
+8 ; Reference to ^PSRX supported by IA #780
+9 ; Reference to ^VA(200 supported by IA #10060
CHECK ;for data to send
+1 SET YSCLT=0
SET YSCLWBC=0
+2 SET $PIECE(YSSTOP,",",3)=3
if $$S^%ZTLOAD
QUIT
+3 KILL PNM,SEX,DOB,AGE,SSN
DO DEM^VADPT
IF 'VAERR
SET PNM=VADM(1)
SET SEX=$PIECE(VADM(5),U)
SET DOB=$PIECE(VADM(3),U)
SET AGE=VADM(4)
SET SSN=$PIECE(VADM(2),U)
+4 ;no transmit for pretreatment
IF YSCLLD=0
IF $PIECE($GET(^PS(55,DFN,"SAND")),"^",2)="P"
QUIT
+5 ;force discontinued
IF YSCLLD
IF YSCLLD<YSCLM56
SET $PIECE(^PS(55,DFN,"SAND"),"^",2)="D"
+6 ;Don't report if over 6 months old.
IF YSCLLD
IF YSCLLD<YSCLM180
QUIT
+7 ;get latest WBC results even if no script.
SET YSCL=$ORDER(YSCLA(""))
IF 'YSCL
DO LAB
SET YSCLT=1
QUIT
+8 ;get latest WBC results even if no script.
SET YSCL1=-$ORDER(YSCLA(YSCL,""))
IF 'YSCL1
DO LAB
SET YSCLT=1
QUIT
+9 ;we've got something
SET YSCLT=1
SET YSCLRX=$GET(^PSRX(YSCL1,0))
SET YSCLRX2=$GET(^PSRX(YSCL1,2))
+10 SET YSCLGL=$SELECT($DATA(^PS(59)):"^PS",1:"^DIC")
+11 ;YSCLGL is used to indirectly hold the global reference for file 59. This is necessary due to changes in the file location. The $select may be expanded to cover future moves. DBIA 273-B
+12 SET YSCLD=+$PIECE($GET(^PSRX(YSCL1,2)),"^",9)
SET YSCLD=$GET(@YSCLGL@(59,YSCLD,"SAND"))
SET $PIECE(YSCLX,"^",10)=$PIECE(YSCLD,"^")
SET $PIECE(YSCLX,"^",12)=$PIECE(YSCLD,"^",2)
+13 ;site DEA# (p10), site pointer (p12)
+14 ;Place on hold status
IF YSCLLD<YSCLM7
SET YSCLWBC=""
SET $PIECE(^PS(55,DFN,"SAND"),"^",2)="H"
SET $PIECE(YSCLX,"^",5)="H"
+15 ;here if active
+16 ;force active
IF $PIECE(YSCLX,"^",5)'="H"
SET $PIECE(^PS(55,DFN,"SAND"),"^",2)="A"
SET $PIECE(YSCLX,"^",5)="A"
+17 SET $PIECE(YSCLX,"^",13)=1
SET $PIECE(YSCLX,"^",9)=$PIECE(YSCLRX,"^",13)
SET YSCLD1=$GET(^PSRX(YSCL1,"SAND"))
SET $PIECE(YSCLX,"^",8)=+YSCLD1
+18 ;status(p5),dosage(p8),rx count(p13),issue date(p9)
+19 SET YSCLLO=$ORDER(^PS(52.52,"A",YSCL1,0))
IF YSCLLO
SET YSCLLO=^PS(52.52,YSCLLO,0)
SET $PIECE(YSCLX,"^",14)=$PIECE(YSCLLO,"^",5)
SET YSCLLO=+$PIECE(YSCLLO,"^",4)
SET $PIECE(YSCLX,"^",15)=$PIECE(^VA(200,YSCLLO,0),"^")
+20 ;lockout reason (p14), approving official (p15)
+21 SET $PIECE(YSSTOP,",",4)=4
if $$S^%ZTLOAD
QUIT
+22 SET YSCLPHY=$GET(^VA(200,+$PIECE(YSCLRX,"^",4),0))
SET $PIECE(YSCLX,"^",7)=$PIECE($GET(^VA(200,+$PIECE(YSCLRX,"^",4),"PS")),"^",2)
SET YSCLPHY=$PIECE(YSCLPHY,"^")
+23 SET $PIECE(YSCLX,"^",4)=1000*$PIECE(YSCLD1,"^",2)
SET $PIECE(YSCLX,"^",3)=$PIECE(YSCLD1,"^",3)
IF $PIECE(YSCLD1,"^",2)]""
IF $PIECE(YSCLD1,"^",3)'>YSCLED
IF $PIECE(YSCLD1,"^",3)'<YSCLM7
SET YSCLWBC=1
+24 ;wbc(p4),date(p3)
+25 SET YSCL2=-$ORDER(YSCLA(YSCL,-YSCL1))
IF YSCL2
IF +$PIECE($GET(^PSRX(YSCL2,0)),"^",6)'=$PIECE(YSCLRX,"^",6)
SET YSCL2=$GET(^PSRX(YSCL2,"SAND"))
SET $PIECE(YSCLX,"^",13)=2
IF $PIECE(YSCL2,"^")'=$PIECE(YSCLX,"^",8)
SET $PIECE(YSCLX,"^",8)=$PIECE(YSCLX,"^",8)+YSCL2
+26 ; add if prescription on same day for different drug and different dose
+27 ;Add NDC to string
SET $PIECE(YSCLX,"^",21)=$PIECE(YSCLRX2,"^",7)
LAB ;get most recent
+1 SET $PIECE(YSSTOP,",",5)=5
if $$S^%ZTLOAD
QUIT
+2 SET YSCLLDT=""
SET J=9999998-YSCLED
SET K=9999998-YSCLM7
IF $PIECE(YSCLX,"^",9)
SET J=9999998-$PIECE(YSCLX,"^",9)
+3 ;Set 3,4,17,19,20,22,23
SET YSCLR=$$CL^YSCLTST2(DFN)
Begin DoDot:1
+4 ;WBC Date
SET $PIECE(YSCLX,"^",3)=$PIECE(YSCLR,"^",6)
+5 ;WBC Results
SET $PIECE(YSCLX,"^",4)=$PIECE(YSCLR,"^",2)
+6 ;S $P(YSCLX,"^",17)=$P(YSCLR,"^",6) ;WBC test count ???
+7 ;ANC Date
SET $PIECE(YSCLX,"^",19)=$PIECE(YSCLR,"^",6)
+8 ;ANC Results
SET $PIECE(YSCLX,"^",20)=$PIECE(YSCLR,"^",4)
+9 ;WBC Name
SET $PIECE(YSCLX,"^",22)=$PIECE(YSCLR,"^",3)
+10 ;ANC Name
SET $PIECE(YSCLX,"^",23)=$PIECE(YSCLR,"^",5)
End DoDot:1
+11 QUIT
LOAD ;
+1 SET $PIECE(YSSTOP,",",6)=6
if $$S^%ZTLOAD
QUIT
+2 IF YSCLWBC=""
IF YSCLLD<YSCLM28
QUIT
+3 ; don't send for pretest or older that 28 days
+4 SET YSCLNSTE=$PIECE($GET(^PS(59,+$PIECE($GET(^PSRX(YSCL1,2)),"^",9),0)),"^",6)
+5 SET YSCLNST1=$PIECE($$SITE^VASITE,"^",2)
SET YSCLNSTE=$PIECE($$SITE^VASITE,"^",3)
+6 SET YSCLLN=YSCLLN+1
SET $PIECE(YSCLX,"^",18)=YSCLRET
SET ^TMP($JOB,YSCLLN,0)=YSCLX
SET YSCLLN=YSCLLN+1
SET ^TMP($JOB,YSCLLN,0)=YSCLPHY_"^"_YSCLDEMO_"^"_YSCLNSTE_"^"_YSCLNST1
+7 ;site number and name
+8 ;S YSCLLLN=YSCLLLN+1,^TMP("YSCL",$J,YSCLLLN,0)=$P(^DPT(DFN,0),"^",9)_" "_$P(^(0),"^")_" "_$S($P(YSCLX,"^",13)="":"NO ",1:" ")_"RX "_$S(YSCLWBC="":"NO ",1:" ")_"LAB" Q
+9 SET YSCLLLN=YSCLLLN+1
SET ^TMP("YSCL",$JOB,YSCLLLN,0)=$PIECE(^DPT(DFN,0),"^",9)_" "_$PIECE(^(0),"^")_" (R) "_$SELECT($PIECE(YSCLX,"^",13)="":"NO RX ",1:$$FMTE^XLFDT($PIECE(YSCLX,"^",9),"D"))_" (W) "
+10 SET ^TMP("YSCL",$JOB,YSCLLLN,0)=^TMP("YSCL",$JOB,YSCLLLN,0)_$SELECT($PIECE(YSCLX,"^",3)="":"NO WBC ",1:$$FMTE^XLFDT($PIECE(YSCLX,"^",3),"D"))_" (N) "_$SELECT($PIECE(YSCLX,"^",20)="":"NO NEUT ",1:$$FMTE^XLFDT($PIECE(YSCLX,"^",19),"D"))
QUIT
+11 ;9the piece for issue date, 16th piece for WBC date ;RLM 06/16/05
+12 QUIT
ZEOR ;YSCLTST1
