source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPSNMD.m@ 1604

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

initial load of WorldVistAEHR

File size: 5.0 KB
Line 
1LRAPSNMD ;DALOI/WTY - Display/print SNOMED codes;08/06/01
2 ;;5.2;LAB SERVICE;**259**;Sep 27, 1994
3 ;
4 Q
5INIT(LRDFN,LRSS,LRI,LRSF,LRAA,LRAN,LRAD,LRDEM,LRDEV) ;
6 ; This routine displays SNOMED codes and their description for the
7 ; given record in the LAB DATA (#63) file.
8 ;
9 ; LRDFN - IEN of the patient's record in the LAB DATA file (#63)
10 ; LRSS - Anatomic Pathology section (i.e. "SP" for Surgical Pathology)
11 ; LRI - Inverse date/time specimen taken
12 ; LRSF - Anatomic Pathology sub-file number (i.e. 63.08 for Surg Path)
13 ; LRAA - IEN of the accession area in the ACCESSION (#68) file
14 ; LRAN - Accession Number
15 ; LRAD - Accession Date
16 ; LRDEM - Demographics Array. The following are used in the header
17 ; code but are not required:
18 ; LRDEM("PNM") - Patient Name
19 ; LRDEM("PRO") - Provider
20 ; LRDEM("AUDT") - Autopsy Date
21 ; LRDEM("AUTYP") - Autopsy Type
22 ; LRDEM("DTH") - Date of Death
23 ; LRDEM("SSN") - Social Security Number
24 ; LRDEM("SEX") - Sex
25 ; LRDEM("AGE") - Age (or Age at Death for AU)
26 ; LRDEM("DOB") - Date of Birth
27 ; LRDEV - 1 indicates use device handling in this routine
28 ; 0 indicates use device handling of calling application
29 ;
30 N LRAU,LRQUIT,LRL
31 Q:'$D(LRSS)!('$D(LRDFN))!('$D(LRSF))!('$D(LRAA))!('+$G(LRAN))
32 Q:'+$G(LRAD)
33 S $P(LRL,"-",79)=""
34 S LRAU=$S(LRSS'="AU":0,1:1)
35 Q:'LRAU&('$D(LRI))
36MAIN ;
37 S LRQUIT=0,LRDEV=+$G(LRDEV)
38 D:LRDEV ASKDEV
39 I $G(POP)!(LRQUIT) D END Q
40 D REPORT
41 D END
42 Q
43CHECK ;
44 N LRSB
45 I LRAU D Q
46 .S LRSB=$Q(^LR(LRDFN,"AY",0))
47 .I $QS(LRSB,2)'="AY" D
48 ..W !!,"No SNOMED codes found."
49 ..S LRQUIT=1
50 S LRSB=$Q(^LR(LRDFN,LRSS,LRI,2,0))
51 I $QS(LRSB,4)'=2 D
52 .W !!,"No SNOMED codes found."
53 .S LRQUIT=1
54 Q
55ASKDEV ;
56 W !
57 S %ZIS="Q" D ^%ZIS
58 I POP W ! S LRQUIT=1 Q
59 I $D(IO("Q")) D
60 .S ZTDESC="LIST OF SNOMED CODES FOR AN ACCESSION"
61 .S ZTSAVE("LR*")="",ZTRTN="REPORT^LRAPSNMD"
62 .D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
63 .K ZTSK,IO("Q") D HOME^%ZIS
64 .S LRQUIT=1
65 Q
66REPORT ;
67 U IO W:IOST["C-" @IOF
68 N LRFILE,LRFILE1,LRFILE2,LRFILE3,LRCASE,LRX
69 N LRA,LRA1,LRA2,LRIENS,LRIENS1,LRIENS2,LRIENS3
70 N LRP1,LRP2,LRP3,LRP4,LRP5,LRDFP,LRPRFX,LRPG,LRACC,LRSEC
71 S LRIENS=LRAN_","_LRAD_","_LRAA_","
72 S LRACC=$$GET1^DIQ(68.02,LRIENS,15,"E")
73 S LRSEC=$$GET1^DIQ(68,LRAA_",",.01)
74 S (LRQUIT,LRPG)=0
75 D HDR
76 ;Print Specimens
77 I 'LRAU D Q:LRQUIT
78 .W !,"Tissue Specimen(s): ",!
79 .S LRX=0
80 .F S LRX=$O(^LR(LRDFN,LRSS,LRI,.1,LRX)) Q:LRX'>0!(LRQUIT) D
81 ..I $Y>(IOSL-5) D HDR Q:LRQUIT
82 ..W ?5,$P($G(^LR(LRDFN,LRSS,LRI,.1,LRX,0)),U),!
83 D CHECK
84 Q:LRQUIT
85 I LRAU D
86 .S LRFILE="^LR(LRDFN,""AY"",",LRFILE1=63.2,LRIENS=LRDFN_",",LRCASE=1
87 I 'LRAU D
88 .S LRFILE="^LR(LRDFN,LRSS,LRI,2,"
89 .S LRFILE1=+$$GET1^DID(LRSF,10,"","SPECIFIER")
90 .S LRIENS=LRI_","_LRDFN_","
91 .S LRCASE=+$$GET1^DIQ(69.2,LRAA_",",.05,"I")
92 S LRA=0 F S LRA=$O(@(LRFILE_"LRA)")) Q:LRA'>0!(LRQUIT) D
93 .;Topography
94 .S LRIENS1=LRA_","_LRIENS
95 .D WRITE(LRFILE1,LRIENS1,LRCASE,"T",0)
96 .;Morphology
97 .S LRA1=0
98 .F S LRA1=$O(@(LRFILE_"LRA,2,LRA1)")) Q:LRA1'>0!(LRQUIT) D
99 ..S LRFILE2=+$$GET1^DID(LRFILE1,4,"","SPECIFIER")
100 ..S LRIENS2=LRA1_","_LRIENS1
101 ..D WRITE(LRFILE2,LRIENS2,LRCASE,"M",5)
102 ..;Etiology
103 ..S LRA2=0
104 ..F S LRA2=$O(@(LRFILE_"LRA,2,LRA1,1,LRA2)")) Q:LRA2'>0!(LRQUIT) D
105 ...S LRFILE3=+$$GET1^DID(LRFILE2,1,"","SPECIFIER")
106 ...S LRIENS3=LRA2_","_LRIENS2
107 ...D WRITE(LRFILE3,LRIENS3,LRCASE,"E",10)
108 .;Disease,Function,Procedure
109 .F LRDFP="1;3","3;1","4;1.5" D
110 ..S LRDFP(1)=$P(LRDFP,";"),LRDFP(2)=$P(LRDFP,";",2),LRA1=0
111 ..F S LRA1=$O(@(LRFILE_"LRA,LRDFP(1),LRA1)")) Q:LRA1'>0!(LRQUIT) D
112 ...S LRFILE2=+$$GET1^DID(LRFILE1,LRDFP(2),"","SPECIFIER")
113 ...S LRIENS2=LRA1_","_LRIENS1
114 ...S LRPRFX=$S(LRDFP(1)=1:"D",LRDFP(1)=3:"F",1:"P")
115 ...D WRITE(LRFILE2,LRIENS2,LRCASE,LRPRFX,5)
116 Q:LRQUIT
117 W !!,$$CJ^XLFSTR("(End of Report)",IOM)
118 Q
119WRITE(LRP1,LRP2,LRP3,LRP4,LRP5) ;
120 ;LRP1=File number
121 ;LRP2=IEN string
122 ;LRP3=Case (Upper or Lower)
123 ;LRP4=Prefix
124 ;LRP5=Tab position
125 N LRSM
126 S LRSM(1)=$$GET1^DIQ(LRP1,LRP2,.01)
127 S:LRP3 LRSM(1)=$$LOW^XLFSTR(LRSM(1))
128 S LRSM(2)=LRP4_"-"_$$GET1^DIQ(LRP1,LRP2,".01:2")
129 W !?LRP5,LRSM(2)_": "_LRSM(1)
130 I LRP4="P" D
131 .S LRSM(3)=$$GET1^DIQ(LRP1,LRP2,.02,"I")
132 .Q:LRSM(3)=""
133 .W " (",$S('LRSM(3):"negative",LRSM(3)=1:"positive",1:"?"),")"
134 I $Y>(IOSL-5) D HDR
135 Q
136HDR ;
137 I LRPG>0,IOST?1"C-".E D Q:LRQUIT
138 .K DIR S DIR(0)="E"
139 .D ^DIR W !
140 .S:$D(DTOUT)!(X[U) LRQUIT=1
141 W:LRPG>0 @IOF S LRPG=LRPG+1
142 W !,LRSEC,?24,"SNOMED CODE LISTING",?49,"Acc: ",LRACC
143 W:IOST'["BROWSE" ?71,"Pg: ",$J(LRPG,3)
144 W !,"Patient: ",$G(LRDEM("PNM"))
145 W ?49,$S(LRAU:"Resident: ",1:"Physician: ")
146 W $E($G(LRDEM("PRO")),1,18)
147 I LRAU D
148 .W !,"Autopsy Date: ",$G(LRDEM("AUDT")),?35,$E($G(LRDEM("AUTYP")),1,12)
149 .W ?49,"Date Died: ",$G(LRDEM("DTH"))
150 W !,"ID: ",$G(LRDEM("SSN"))
151 I 'LRAU D
152 .W ?24,"Sex: ",$G(LRDEM("SEX")),?49,"DOB: ",$G(LRDEM("DOB"))
153 .W ?71,"Age:",$J($G(LRDEM("AGE")),3)
154 I LRAU D
155 .W ?24,"DOB: ",$G(LRDEM("DOB")),?49,"Age At Death: ",$G(LRDEM("AGE"))
156 .W ?72,"Sex: ",$G(LRDEM("SEX"))
157 W !,LRL
158 Q
159END ;
160 W:IOST?1"P-".E @IOF
161 I LRDEV D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
162 K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
163 Q
Note: See TracBrowser for help on using the repository browser.