source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRLCAT1.m@ 1211

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

initial load of WorldVistAEHR

File size: 4.8 KB
Line 
1IMRLCAT1 ;HCIOFO/FT/FAI-DISTRIBUTION OF PATIENTS BY CAT ;07/17/00 16:08
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;**5**;Feb 09, 1998
3PRNT ; Print Patients By Category
4 D NOW^%DTC S IMRDTE=%,(IMRPG,IMRREC,IMRUT)=0
5 S Y=IMRDTE D DD^%DT S IMRDTE=Y
6 D HEDR K IMRX
7 F IMRTY="A","S","Y","M","R","RI","E","P","Z" S IMRX(IMRTY)=0 S A="" F J=0:0 S A=$O(^TMP($J,IMRTY,A)) Q:A="" S IMRX(IMRTY)=IMRX(IMRTY)+1
8 F IMRTY="A","S","Y","M","R","RI","E","P","Z" Q:(IMRUT) D:($Y+4+IMRX(IMRTY))>IOSL HDR Q:IMRUT W !! S A="" F J=0:0 S A=$O(^TMP($J,IMRTY,A)) Q:A=""!(IMRUT) D PR1
9 Q:IMRUT
10 I $D(IMRTEST),IMRTEST D LIST
11 Q
12PR1 ;
13 W !,$S(IMRTY="Y":$J(A,3)_" years",1:A) S IMRNODE=$G(^TMP($J,IMRTY,A)),Z=0 F I=1:1:5 S Y=$S(I=5:Z,1:+$P(IMRNODE,U,I)) W ?(34+(I-1*10)),$J(Y,4) S Z=Z+Y S:'IMRREC IMRREC=1
14 Q
15HDR ; Check End Of Page
16 Q:'IMRREC
17 S IMRUT=0
18 Q:$D(IO("S")) ;slaved device
19 I ($E(IOST,1,2)="C-"&IMRPG) W ! S DIR(0)="E" D ^DIR K DIR I 'Y S IMRUT=1 Q
20HEDR ; Header of Report
21 S X="Local ICR Demographics by Category"
22 W:$Y>0 @IOF S IMRPG=IMRPG+1
23 W !,IMRDTE,?72,"Page ",IMRPG,! W !?(50-$L(X))\2+30,X,!,?$S($L(IMRHED)'>50:(50-$L(IMRHED))\2+30,1:79-$L(IMRHED)),IMRHED,!!?33,"HIV+",?42,"HIV+TC",?53,"AIDS-3",?64,"AIDS",?73,"TOTAL",!
24 Q
25PERCHK ; Check Patient Lab
26 S IMRCHK=0
27 Q:$G(IMRHNBEG)="" Q:$G(IMRHNEND)=""
28 S DFN=IMRDFN,VASD("F")=IMRHNBEG,VASD("T")=IMRHNEND D SDA^VADPT ;appt date/time
29 I $O(^UTILITY("VASD",$J,0))>0 S IMRCHK=1,IMRSCH=1
30 ; array piece 1 - date/time of appointment
31 ; 2 - clinic
32 ; 3 - status
33 ; 4 - appointment type
34 K DFN,VASD,^UTILITY("VASD",$J)
35 F IMRPTF=0:0 S IMRPTF=$O(^DGPT("B",IMRDFN,IMRPTF)) Q:IMRPTF'>0 I $D(^DGPT(IMRPTF,0)) D PTF^IMRUTL D
36 . S IMRDD=+IMRDD,IMRAD=IMRAD\1 S:IMRDD IMRDD=IMRDD\1
37 . I (IMRDD=0&(IMRAD'>IMRHNEND))!(IMRAD<(IMRHNEND+1)&(IMRDD'<IMRHNBEG)) D I $D(IMRINP) S IMRCHK=1 Q
38 . . I IMRSUF'="",'(IMRSUF="9AA"!(IMRSUF="A0")!(IMRSUF="9AB")!(IMRSUF="9BB")!(IMRSUF="A4")!(IMRSUF="A5")) Q
39 . . I IMREC>1 Q
40 . . S IMRINP=1
41 . . Q
42 . Q
43 I $D(^DPT(IMRDFN,"LR")),^("LR")>0 S IMRLR=^("LR") F IMRJ=9999999-IMRHNEND-1:0 S IMRJ=$O(^LR(IMRLR,"CH",IMRJ)) Q:IMRJ'>0!(IMRJ>(9999999-IMRHNBEG)) S IMRLAB=1,IMRCHK=1 Q
44 F IMRJ=0:0 Q:$D(IMRRX) S IMRJ=$O(^PS(55,IMRDFN,"P","A",IMRJ)) Q:IMRJ'>0 F IMRRXN=0:0 S IMRRXN=$O(^PS(55,IMRDFN,"P","A",IMRJ,IMRRXN)) Q:IMRRXN'>0 I $D(^PSRX(IMRRXN,0)) D I $D(IMRRX) S IMRCHK=1 Q
45 . N X1 S X1=$G(^PSRX(IMRRXN,2)) S X1=$P(X1,U,2) D ;X1=fill date-file 52
46 . . Q:X1'>0 Q:X1<IMRHNBEG Q:X1'<(IMRHNEND+1)
47 . . S IMRRX=1 Q
48 . F X1=0:0 Q:$D(IMRRX) S X1=$O(^PSRX(IMRRXN,1,X1)) Q:X1'>0 D
49 . . Q:^PSRX(IMRRXN,1,X1,0)<IMRHNBEG Q:^(0)'<(IMRHNEND+1) ;check refill date
50 . . S IMRRX=1
51 . . Q
52 . Q
53 Q
54LIST ;list patients missing data values
55 I '$D(^TMP($J,"ZZTEST")) Q
56 N I,J,LINES,IMRDONE
57 D PRTC Q:$D(IMRDONE)
58 D LISTHDR
59 S LINES=1
60 S I="" F S I=$O(^TMP($J,"ZZTEST","FIN",I)) Q:I="" D Q:$D(IMRDONE)
61 . S J="" F S J=$O(^TMP($J,"ZZTEST","FIN",I,J)) Q:J="" D Q:$D(IMRDONE)
62 . . I ($Y+3>IOSL) D PRTC Q:$D(IMRDONE) D LISTHDR
63 . . S IMRNODE=^TMP($J,"ZZTEST","FIN",I,J)
64 . . W !?1,I,?33,J,?49,$P(IMRNODE,U,1),?54,$P(IMRNODE,U,2),?59,$P(IMRNODE,U,3),?64,$P(IMRNODE,U,4),?69,$P(IMRNODE,U,5),?74,$P(IMRNODE,U,6)
65 . . S LINES=LINES+1
66 . . I LINES>5 W ! S LINES=1
67 . . Q
68 . Q
69 D PRTC
70 Q
71LISTHDR ;header for list of missing data values
72 W @IOF,!,IMRHENGD,?72,"Page ",IMRPG+1,!
73 W !,?49,"SEX",?54,"DOB",?59,"RISK",?64,"RACE",?69,"ELIG",?74,"POS"
74 W !,?49,"---",?54,"---",?59,"----",?64,"----",?69,"----",?74,"---"
75 Q
76PRTC ;press return to continue prompt
77 Q:$E(IOST)'="C"!($D(IO("S")))
78 K DIR W ! S DIR(0)="E" D ^DIR K DIR I 'Y S IMRDONE=1
79 Q
80CHKCAT ; Check Entries For No Category Value
81 ;I $D(IMRMCAT) Q
82 S IMRMCAT=""
83 ;I '$D(^XUSEC("IMRMGR",DUZ))&'$D(^XUSEC("IMRA",DUZ)) Q
84 U IO
85 W !!,"Checking for entries in the ICR file without CATEGORY data.",!
86 K ^TMP($J,"CHKCAT")
87 S IMRCNT=0
88 F IMRI=0:0 S IMRI=$O(^IMR(158,IMRI)) Q:IMRI'>0 I $P($G(^(IMRI,0)),U,42)="" S IMRCNT=IMRCNT+1,^TMP($J,"CHKCAT",IMRI)=""
89 I IMRCNT=0 W " None found.",!
90 I IMRCNT>0 D
91 . W !!,$C(7),"There "_$S(IMRCNT>1:"are ",1:"is ")_IMRCNT_$S(IMRCNT>1:" entries",1:" entry")_" in the IMMUNOLOGY CASE REGISTRY file with",!,"NO CATEGORY indicated --",!!
92 . K DIR S DIR(0)="Y",DIR("A")="DO YOU WANT TO SEE THE LIST",DIR("B")="YES" D ^DIR K DIR I Y'>0 Q
93 . S IMRMC=Y
94 . D IMRDEV^IMREDIT
95 . Q:POP
96 . I $D(IO("Q")) D Q
97 . . S ZTIO=ION,ZTDTH="NOW",ZTRTN="DQ^IMRLCAT1",ZTREQ="@",ZTSAVE("ZTREQ")="",ZTSAVE("^TMP($J,""CHKCAT"",")="",ZTDESC="Missing Categories" D ^%ZTLOAD K ZTSAVE,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTSAVE
98 . . Q
99 . D DQ
100 . Q:$D(IO("S")) ;slaved output
101 . S DIR(0)="E" D ^DIR K DIR
102 . Q
103 K ^TMP($J,"CHKCAT")
104 K IMRI,IMRCNT,X,Y D ^%ZISC
105 Q
106DQ ;
107 U IO
108 F IMRI=0:0 S IMRI=$O(^TMP($J,"CHKCAT",IMRI)) Q:IMRI'>0 D
109 . S X=$P(^IMR(158,IMRI,0),U) D XOR^IMRXOR S DFN=X
110 . D DEM^VADPT
111 . W !,VADM(1),?32,$P(VADM(2),U,2)
112 . K VADM,VAIDXD Q
113 D ^%ZISC
114 Q
Note: See TracBrowser for help on using the repository browser.