Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YSCLTST1

YSCLTST1.m

Go to the documentation of this file.
  1. 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
  1. ; Reference to ^DPT supported by IA #10035
  1. ; Reference to ^LR supported by IA #2657
  1. ; Reference to ^LAB supported by IA #333
  1. ; Reference to ^PS(52.52 supported by IA #782
  1. ; Reference to ^PS(55 supported by IA #787
  1. ; Reference to ^PS(59 supported by IA #783
  1. ; Reference to ^PSRX supported by IA #780
  1. ; Reference to ^VA(200 supported by IA #10060
  1. CHECK ;for data to send
  1. S YSCLT=0,YSCLWBC=0
  1. S $P(YSSTOP,",",3)=3 Q:$$S^%ZTLOAD
  1. 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)
  1. I YSCLLD=0,$P($G(^PS(55,DFN,"SAND")),"^",2)="P" Q ;no transmit for pretreatment
  1. I YSCLLD,YSCLLD<YSCLM56 S $P(^PS(55,DFN,"SAND"),"^",2)="D" ;force discontinued
  1. I YSCLLD,YSCLLD<YSCLM180 Q ;Don't report if over 6 months old.
  1. S YSCL=$O(YSCLA("")) I 'YSCL D LAB S YSCLT=1 Q ;get latest WBC results even if no script.
  1. S YSCL1=-$O(YSCLA(YSCL,"")) I 'YSCL1 D LAB S YSCLT=1 Q ;get latest WBC results even if no script.
  1. S YSCLT=1,YSCLRX=$G(^PSRX(YSCL1,0)),YSCLRX2=$G(^PSRX(YSCL1,2)) ;we've got something
  1. S YSCLGL=$S($D(^PS(59)):"^PS",1:"^DIC")
  1. ;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
  1. 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)
  1. ;site DEA# (p10), site pointer (p12)
  1. I YSCLLD<YSCLM7 S YSCLWBC="",$P(^PS(55,DFN,"SAND"),"^",2)="H",$P(YSCLX,"^",5)="H" ;Place on hold status
  1. ;here if active
  1. I $P(YSCLX,"^",5)'="H" S $P(^PS(55,DFN,"SAND"),"^",2)="A",$P(YSCLX,"^",5)="A" ;force active
  1. S $P(YSCLX,"^",13)=1,$P(YSCLX,"^",9)=$P(YSCLRX,"^",13),YSCLD1=$G(^PSRX(YSCL1,"SAND")),$P(YSCLX,"^",8)=+YSCLD1
  1. ;status(p5),dosage(p8),rx count(p13),issue date(p9)
  1. 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),"^")
  1. ;lockout reason (p14), approving official (p15)
  1. S $P(YSSTOP,",",4)=4 Q:$$S^%ZTLOAD
  1. S YSCLPHY=$G(^VA(200,+$P(YSCLRX,"^",4),0)),$P(YSCLX,"^",7)=$P($G(^VA(200,+$P(YSCLRX,"^",4),"PS")),"^",2),YSCLPHY=$P(YSCLPHY,"^")
  1. 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
  1. ;wbc(p4),date(p3)
  1. 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
  1. ; add if prescription on same day for different drug and different dose
  1. S $P(YSCLX,"^",21)=$P(YSCLRX2,"^",7) ;Add NDC to string
  1. LAB ;get most recent
  1. S $P(YSSTOP,",",5)=5 Q:$$S^%ZTLOAD
  1. S YSCLLDT="",J=9999998-YSCLED,K=9999998-YSCLM7 I $P(YSCLX,"^",9) S J=9999998-$P(YSCLX,"^",9)
  1. S YSCLR=$$CL^YSCLTST2(DFN) D ;Set 3,4,17,19,20,22,23
  1. . S $P(YSCLX,"^",3)=$P(YSCLR,"^",6) ;WBC Date
  1. . S $P(YSCLX,"^",4)=$P(YSCLR,"^",2) ;WBC Results
  1. . ;S $P(YSCLX,"^",17)=$P(YSCLR,"^",6) ;WBC test count ???
  1. . S $P(YSCLX,"^",19)=$P(YSCLR,"^",6) ;ANC Date
  1. . S $P(YSCLX,"^",20)=$P(YSCLR,"^",4) ;ANC Results
  1. . S $P(YSCLX,"^",22)=$P(YSCLR,"^",3) ;WBC Name
  1. . S $P(YSCLX,"^",23)=$P(YSCLR,"^",5) ;ANC Name
  1. Q
  1. LOAD ;
  1. S $P(YSSTOP,",",6)=6 Q:$$S^%ZTLOAD
  1. I YSCLWBC="",YSCLLD<YSCLM28 Q
  1. ; don't send for pretest or older that 28 days
  1. S YSCLNSTE=$P($G(^PS(59,+$P($G(^PSRX(YSCL1,2)),"^",9),0)),"^",6)
  1. S YSCLNST1=$P($$SITE^VASITE,"^",2),YSCLNSTE=$P($$SITE^VASITE,"^",3)
  1. S YSCLLN=YSCLLN+1,$P(YSCLX,"^",18)=YSCLRET,^TMP($J,YSCLLN,0)=YSCLX,YSCLLN=YSCLLN+1,^TMP($J,YSCLLN,0)=YSCLPHY_"^"_YSCLDEMO_"^"_YSCLNSTE_"^"_YSCLNST1
  1. ;site number and name
  1. ;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
  1. 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) "
  1. 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
  1. ;9the piece for issue date, 16th piece for WBC date ;RLM 06/16/05
  1. Q
  1. ZEOR ;YSCLTST1