source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRMIHDR.m@ 938

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

initial load of WorldVistAEHR
File size: 4.1 KB
Line 
1LRMIHDR ;DALOI/CJS/BA/RLM-HEALTH DEPARTMENT REPORT ;2/19/91 10:46
2 ;;5.2;LAB SERVICE;**45,272,298**;Sep 27, 1994
3 ; Reference to ^%DT supported by DBIA #10003
4 ; Reference to ^%ZISC supported by DBIA #10089
5 ; Reference to EN^DIQ supported by DBIA #10004
6 ; Reference to KVAR^VADPT supported by DBIA #10061
7 ; Reference to $$NOW^XLFDT supported by IA #10103
8 ; Reference to $$FMTE^XLFDT supported by IA #10103
9 ; Reference to ^DIC(10 supported by IA #925
10 ; Reference to ^DIC( supported by IA #916
11 ; Reference to ^DIC(11 supported by IA #924
12BEGIN S LREND=0,LREDT="T-1" D ^LRWU3 I 'LREND S ZTRTN="DQ^LRMIHDR" D IO^LRWU
13END W !! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC
14 K %DT,A,AGE,D0,DA,DFN,DIC,DL,DOB,DR,DX,I,LRACC,LRBUG,LROCCU,LRDFN,LRDPF,LRDT,LREDT,LREND,LRHC,LRIDT,LRMARST,LRPHONE,LRRACE,LRSAMP,LRSDT,LRSPEC,LRWRD,POP,PNM,S,SEX,SSN,X,Y,Z0
15 D KVAR^LRX
16 Q
17DQ S:$D(ZTQUEUED) ZTREQ="@" U IO
18 I LRSDT>LREDT S X=LRSDT,LRSDT=LREDT,LRSDT=X
19 S LRHC=$E(IOST,1,2)'="C-" W !!,?5,"HEALTH DEPARTMENT REPORT (" S X=LRSDT\1 D ^%DT,DD^LRX W Y," - " S X=LREDT\1 D ^%DT,DD^LRX W Y,")",?65 S X="N",%DT="T" D ^%DT,DD^LRX W Y I LRHC W !! D DASH^LRX
20 S LRDT=LREDT-.0001 F S LRDT=$O(^LR("AD",LRDT)) Q:LRDT<1!(LRDT>LRSDT) D DATE Q:LREND
21 D END
22 Q
23DATE S DR=.11 S LRBUG=0 F S LRBUG=$O(^LR("AD",LRDT,LRBUG)) Q:LRBUG<1 D LIST Q:LREND
24 Q
25LIST W !!,?5,"Isolated Organism: ",$P(^LAB(61.2,LRBUG,0),U),!,"Printed : "_$$FMTE^XLFDT($$NOW^XLFDT,""),!
26 S LRACC="" F S LRACC=$O(^LR("AD",LRDT,LRBUG,LRACC)) Q:LRACC="" S LRDFN=^(LRACC) D SPEC,PAT,WAIT:'LRHC Q:LREND
27 D:LRHC DASH^LRX W !
28 Q
29SPEC S (LRIDT,LRSPEC,LRSAMP)=0 F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1 I $D(^(LRIDT,0)),$E(LRACC,1,$L(LRACC)-1)=$P(^(0),U,6) S LRSPEC=+$P(^(0),U,5),LRSAMP=+$P(^(0),U,11) W:LRSPEC!LRSAMP ! Q
30 I LRSAMP,$D(^LAB(62,LRSAMP,0)) W ?4," COLLECTION SAMPLE: ",$P(^(0),U)
31 I LRSPEC,$D(^LAB(61,LRSPEC,0)) W ?40," SPECIMEN: ",$P(^(0),U)
32 Q
33PAT D KVAR^VADPT
34 W !! S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),DIC=^DIC(+LRDPF,0,"GL") D PT^LRX
35 S Y=DOB D DD^LRX W !!,PNM,?25," ID: ",SSN,?44," DOB: ",Y,?60," SEX: ",SEX
36 I +LRDPF=2 D ADDPT^LRX,OPDPT^LRX D
37 . S LRPHONE=$G(VAPA(8)),LRMARST=$P($G(VADM(10)),U,2),LROCCU=VAPD(6)
38 E S X=DIC_"DFN"_",0)",LRRACE=$P($G(^DIC(10,+$P(@X,U,6),0)),U) D
39 . S X=DIC_DFN_",.13)",LRPHONE=$S($D(@X):$P(^(.13),U),1:"")
40 . S X=DIC_DFN_",0)",X=@X,LRRACE=$P(X,U,6),LRMARST=$P(X,U,5),LROCCU=$P(X,U,7)
41 . I LRRACE S LRRACE=$S($D(^DIC(10,LRRACE,0)):$P(^(0),U),1:"")
42 . I LRMARST S LRMARST=$S($D(^DIC(11,LRMARST,0)):$P(^(0),U),1:"")
43 W !,"Accession Number: ",LRACC,!
44 W:$L(LRPHONE) !,"PHONE: ",LRPHONE
45 D RACE
46 I $L($G(LRRACE))!$L(LRMARST)!$L(LROCCU) W !
47 W:$L($G(LRRACE)) "RACE: ",LRRACE," " W:$L(LRMARST) "MARRIAGE STATUS: ",LRMARST," " W:$L(LROCCU) "OCCUPATION: ",LROCCU
48 S DA=DFN D EN^DIQ S:$D(DTOUT)!($D(DUOUT)) LREND=1
49 D KVAR^VADPT
50 Q
51WAIT F I=$Y:1:IOSL-3 W !
52 W ?59," PRESS '^' TO STOP " R X:DTIME S:X="" X=1 S LREND=".^"[X W:'LREND @IOF
53 Q
54RACE ;ETHNICITY AND RACE MODS
55 ;-----ethnicity/race retrieval and display
56 K ERT,SEQ
57 S (ERT,SEQ)="" ;ERT=ethnicity race type; display multiple for both
58 I $D(VADM(11)) I VADM(11)>0 S SEQ=SEQ+1,ERT(SEQ)="" D
59 . F I=1:1 Q:'$D(VADM(11,I)) I $TR($P(VADM(11,I),"^",2),"")'="" D
60 .. ;length of race or ethnicity; plus 25 characters for field label; plus length of data to be added to the field; minus 2 char for comma and space; up to 80 characters.
61 .. I ($L(ERT(SEQ))+25+$L($P(VADM(11,I),"^",2))-2)'>80 D Q
62 ... S ERT(SEQ)=ERT(SEQ)_", "_$P(VADM(11,I),"^",2)
63 S:'$D(ERT(1)) ERT(1)=", UNANSWERED"
64 W !,"Veteran's ethnicity: "_$E(ERT(1),3,999)
65 I SEQ>1 F I=2:1:SEQ W !?30,$E(ERT(I),3,999)
66 K ERT S (ERT,SEQ)=""
67 I $D(VADM(12)) I VADM(12)>0 S SEQ=SEQ+1,ERT(SEQ)="" D
68 . F I=1:1:VADM(12) Q:'$D(VADM(12,I)) I $TR($P(VADM(12,I),"^",2),"")'="" D
69 .. I ($L(ERT(SEQ))+25+$L($P(VADM(12,I),"^",2))-2)'>80 D Q
70 ... S ERT(SEQ)=ERT(SEQ)_", "_$P(VADM(12,I),"^",2)
71 .. I ($L(ERT(SEQ))+25+$L($P(VADM(12,I),"^",2))-2)>80 D
72 ... S ERT(SEQ)=ERT(SEQ)_", ",SEQ=SEQ+1,ERT(SEQ)=""
73 .. S ERT(SEQ)=ERT(SEQ)_", "_$P(VADM(12,I),"^",2)
74 S:'$D(ERT(1)) ERT(1)=", UNANSWERED"
75 I ERT(1)=", UNANSWERED",$G(VADM(8)) S ERT(1)=" "_$P(VADM(8),U,2)
76 W !,"Veteran's race: "_$E(ERT(1),3,999)
77 I SEQ>1 F I=2:1:SEQ W !?25,$E(ERT(I),3,999)
78 K ERT,SEQ
79 Q
Note: See TracBrowser for help on using the repository browser.