- 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 Feb 18, 2025@23:40:10 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