source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLTST1.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.4 KB
Line 
1YSCLTST1 ;DALOI/LB/RLM-COLLECT RX AND LAB DATA FOR CLOZAPINE ;18 Feb 93
2 ;;5.01;MENTAL HEALTH;**18,22,25,26,47,61,69,74,90**;Dec 30, 1994;Build 18
3 ; Reference to ^DPT supported by IA #10035
4 ; Reference to ^LR supported by IA #2657
5 ; Reference to ^LAB supported by IA #333
6 ; Reference to ^PS(52.52 supported by IA #782
7 ; Reference to ^PS(55 supported by IA #787
8 ; Reference to ^PS(59 supported by IA #783
9 ; Reference to ^PSRX supported by IA #780
10 ; Reference to ^VA(200 supported by IA #10060
11CHECK ;for data to send
12 S YSCLT=0,YSCLWBC=0
13 S $P(YSSTOP,",",3)=3 Q:$$S^%ZTLOAD
14 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)
15 I YSCLLD=0,$P($G(^PS(55,DFN,"SAND")),"^",2)="P" Q ;no transmit for pretreatment
16 I YSCLLD,YSCLLD<YSCLM56 S $P(^PS(55,DFN,"SAND"),"^",2)="D" ;force discontinued
17 I YSCLLD,YSCLLD<YSCLM180 Q ;Don't report if over 6 months old.
18 S YSCL=$O(YSCLA("")) I 'YSCL D LAB S YSCLT=1 Q ;get latest WBC results even if no script.
19 S YSCL1=-$O(YSCLA(YSCL,"")) I 'YSCL1 D LAB S YSCLT=1 Q ;get latest WBC results even if no script.
20 S YSCLT=1,YSCLRX=$G(^PSRX(YSCL1,0)),YSCLRX2=$G(^PSRX(YSCL1,2)) ;we've got something
21 S YSCLGL=$S($D(^PS(59)):"^PS",1:"^DIC")
22 ;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
23 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)
24 ;site DEA# (p10), site pointer (p12)
25 I YSCLLD<YSCLM7 S YSCLWBC="",$P(^PS(55,DFN,"SAND"),"^",2)="H",$P(YSCLX,"^",5)="H" ;Place on hold status
26 ;here if active
27 I $P(YSCLX,"^",5)'="H" S $P(^PS(55,DFN,"SAND"),"^",2)="A",$P(YSCLX,"^",5)="A" ;force active
28 S $P(YSCLX,"^",13)=1,$P(YSCLX,"^",9)=$P(YSCLRX,"^",13),YSCLD1=$G(^PSRX(YSCL1,"SAND")),$P(YSCLX,"^",8)=+YSCLD1
29 ;status(p5),dosage(p8),rx count(p13),issue date(p9)
30 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),"^")
31 ;lockout reason (p14), approving official (p15)
32 S $P(YSSTOP,",",4)=4 Q:$$S^%ZTLOAD
33 S YSCLPHY=$G(^VA(200,+$P(YSCLRX,"^",4),0)),$P(YSCLX,"^",7)=$P($G(^VA(200,+$P(YSCLRX,"^",4),"PS")),"^",2),YSCLPHY=$P(YSCLPHY,"^")
34 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
35 ;wbc(p4),date(p3)
36 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
37 ; add if prescription on same day for different drug and different dose
38 S $P(YSCLX,"^",21)=$P(YSCLRX2,"^",7) ;Add NDC to string
39LAB ;get most recent
40 S $P(YSSTOP,",",5)=5 Q:$$S^%ZTLOAD
41 S YSCLLDT="",J=9999998-YSCLED,K=9999998-YSCLM7 I $P(YSCLX,"^",9) S J=9999998-$P(YSCLX,"^",9)
42 S YSCLR=$$CL^YSCLTST2(DFN) D ;Set 3,4,17,19,20,22,23
43 . S $P(YSCLX,"^",3)=$P(YSCLR,"^",6) ;WBC Date
44 . S $P(YSCLX,"^",4)=$P(YSCLR,"^",2) ;WBC Results
45 . ;S $P(YSCLX,"^",17)=$P(YSCLR,"^",6) ;WBC test count ???
46 . S $P(YSCLX,"^",19)=$P(YSCLR,"^",6) ;ANC Date
47 . S $P(YSCLX,"^",20)=$P(YSCLR,"^",4) ;ANC Results
48 . S $P(YSCLX,"^",22)=$P(YSCLR,"^",3) ;WBC Name
49 . S $P(YSCLX,"^",23)=$P(YSCLR,"^",5) ;ANC Name
50 Q
51LOAD ;
52 S $P(YSSTOP,",",6)=6 Q:$$S^%ZTLOAD
53 I YSCLWBC="",YSCLLD<YSCLM28 Q
54 ; don't send for pretest or older that 28 days
55 S YSCLNSTE=$P($G(^PS(59,+$P($G(^PSRX(YSCL1,2)),"^",9),0)),"^",6)
56 S YSCLNST1=$P($$SITE^VASITE,"^",2),YSCLNSTE=$P($$SITE^VASITE,"^",3)
57 S YSCLLN=YSCLLN+1,$P(YSCLX,"^",18)=YSCLRET,^TMP($J,YSCLLN,0)=YSCLX,YSCLLN=YSCLLN+1,^TMP($J,YSCLLN,0)=YSCLPHY_"^"_YSCLDEMO_"^"_YSCLNSTE_"^"_YSCLNST1
58 ;site number and name
59 ;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
60 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) "
61 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
62 ;9the piece for issue date, 16th piece for WBC date ;RLM 06/16/05
63 Q
64ZEOR ;YSCLTST1
Note: See TracBrowser for help on using the repository browser.