source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRAPBR2.m@ 1535

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

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1LRAPBR2 ;DALOI/WTY/KLL - AP Browser Print ;04/04/01
2 ;;5.2;LAB SERVICE;**259**;Sep 27, 1994
3 ;
4 ; This routine is a modified version of LRAPT1 to be used for
5 ; browser display.
6 ;
7 N LRSS,LRI,LRPATH,LRIENS,LRACN,LRRLDTE,LRRCDTE
8 N LRTEXT,LRI1,LRI2,LRIENS1,LRSPC
9 S LR("F")=1
10 F LRSS="SP","CY","EM" D
11 .Q:'+$P($G(^LR(LRDFN,LRSS,0)),"^",4)
12 .S LRTMP=""
13 .S:LRSS="SP" LRTMP="SURGICAL PATHOLOGY",(LRFILE,LRXF)=63.08
14 .S:LRSS="CY" LRTMP="CYTOPATHOLOGY",(LRFILE,LRXF)=63.09
15 .S:LRSS="EM" LRTMP="ELECTRON MICROSCOPY",(LRFILE,LRXF)=63.02
16 .D GLENTRY("","",1),GLENTRY(LRTMP,30,1)
17 .K LRTMP
18 .S LRI=0 F S LRI=$O(^LR(LRDFN,LRSS,LRI)) Q:'LRI D
19 ..S LRIENS=LRI_","_LRDFN_","
20 ..S LRPATH=$E($$GET1^DIQ(LRFILE,LRIENS,.02,""),1,12)
21 ..S LRACN=$$GET1^DIQ(LRFILE,LRIENS,.06,"")
22 ..S:LRACN="" LRACN="?"
23 ..S LRRLDTE=$$GET1^DIQ(LRFILE,LRIENS,.11,"")
24 ..S LRRCDTE=$$FMTE^XLFDT($$GET1^DIQ(LRFILE,LRIENS,.1,"I"),"D")
25 ..D GLENTRY("Organ/tissue:",2,1)
26 ..D GLENTRY("Date rec'd: "_LRRCDTE,17)
27 ..D GLENTRY("Acc #:"_LRACN,43)
28 ..D GLENTRY(LRPATH,64)
29 ..I LRRLDTE="" D GLENTRY("Report not verified.",5,1)
30 ..;KLL - Display Snomed Codes on report in Browser
31 ..D GETSNMD
32 ..Q:LRRLDTE=""
33 ..;Special Studies
34 ..S LRFILE1=+$$GET1^DID(LRFILE,10,"","SPECIFIER")
35 ..S LRI1=0 F S LRI1=$O(^LR(LRDFN,LRSS,LRI,2,LRI1)) Q:'LRI1 D
36 ...S LRFILE2=+$$GET1^DID(LRFILE1,5,"","SPECIFIER")
37 ...S LRI2=0 F S LRI2=$O(^LR(LRDFN,LRSS,LRI,2,LRI1,5,LRI2)) Q:'LRI2 D
38 ....S LRIENS1=LRI2_","_LRI1_","_LRIENS
39 ....D GETS^DIQ(LRFILE2,LRIENS1,".01;.03","","LRARR")
40 ....M LRSPC=LRARR(LRFILE2,LRIENS1)
41 ....S LRSPC(.02)=$$GET1^DIQ(LRFILE2,LRIENS1,.02,"E")
42 ....S LRTEXT=LRSPC(.01)_" "_LRSPC(.03)_" Date: "_LRSPC(.02)
43 ....D GLENTRY(LRTEXT,5,1)
44 Q
45GETSNMD ;Retrieve SNOMED codes, desc. for display to Browser
46 S LRQUIT=0
47 D CHKSNMD
48 Q:LRQUIT
49 I LRAU D
50 .S LRFIL="^LR(LRDFN,""AY"",",LRFILE1=63.2,LRIENS=LRDFN_",",LRCASE=1
51 I 'LRAU D
52 .S LRFIL="^LR(LRDFN,LRSS,LRI,2,"
53 .S LRFILE1=+$$GET1^DID(LRFILE,10,"","SPECIFIER")
54 .S LRIENS=LRI_","_LRDFN_","
55 .S LRCASE=+$$GET1^DIQ(69.2,LRAA_",",.05,"I")
56 S LRA=0 F S LRA=$O(@(LRFIL_"LRA)")) Q:LRA'>0!(LRQUIT) D
57 .;Topography
58 .S LRIENS1=LRA_","_LRIENS
59 .D WRTSNMD(LRFILE1,LRIENS1,LRCASE,"T",0)
60 .;Morphology
61 .S LRA1=0
62 .F S LRA1=$O(@(LRFIL_"LRA,2,LRA1)")) Q:LRA1'>0!(LRQUIT) D
63 ..S LRFILE2=+$$GET1^DID(LRFILE1,4,"","SPECIFIER")
64 ..S LRIENS2=LRA1_","_LRIENS1
65 ..D WRTSNMD(LRFILE2,LRIENS2,LRCASE,"M",5)
66 ..;Etiology
67 ..S LRA2=0
68 ..F S LRA2=$O(@(LRFIL_"LRA,2,LRA1,1,LRA2)")) Q:LRA2'>0!(LRQUIT) D
69 ...S LRFILE3=+$$GET1^DID(LRFILE2,1,"","SPECIFIER")
70 ...S LRIENS3=LRA2_","_LRIENS2
71 ...D WRTSNMD(LRFILE3,LRIENS3,LRCASE,"E",10)
72 .;Disease,Function,Procedure
73 .F LRDFP="1;3","3;1","4;1.5" D
74 ..S LRDFP(1)=$P(LRDFP,";"),LRDFP(2)=$P(LRDFP,";",2),LRA1=0
75 ..F S LRA1=$O(@(LRFIL_"LRA,LRDFP(1),LRA1)")) Q:LRA1'>0!(LRQUIT) D
76 ...S LRFILE2=+$$GET1^DID(LRFILE1,LRDFP(2),"","SPECIFIER")
77 ...S LRIENS2=LRA1_","_LRIENS1
78 ...S LRPRFX=$S(LRDFP(1)=1:"D",LRDFP(1)=3:"F",1:"P")
79 ...D WRTSNMD(LRFILE2,LRIENS2,LRCASE,LRPRFX,5)
80 Q
81CHKSNMD ;Check for SNOMED codes on the accession
82 N LRSB
83 I LRAU D Q
84 .S LRSB=$Q(^LR(LRDFN,"AY",0))
85 .I $QS(LRSB,2)'="AY" S LRQUIT=1
86 S LRSB=$Q(^LR(LRDFN,LRSS,LRI,2,0))
87 I $QS(LRSB,4)'=2 S LRQUIT=1
88 Q
89WRTSNMD(LRP1,LRP2,LRP3,LRP4,LRP5) ;
90 ;LRP1=File number
91 ;LRP2=IEN string
92 ;LRP3=Case (Upper or Lower)
93 ;LRP4=Prefix
94 ;LRP5=Tab position
95 N LRSM
96 S LRSM(1)=$$GET1^DIQ(LRP1,LRP2,.01)
97 S:LRP3 LRSM(1)=$$LOW^XLFSTR(LRSM(1))
98 S LRSM(2)=LRP4_"-"_$$GET1^DIQ(LRP1,LRP2,".01:2")
99 S LRTXT=LRSM(2)_": "_LRSM(1)
100 I LRP4="P" D
101 .S LRSM(3)=$$GET1^DIQ(LRP1,LRP2,.02,"I")
102 .I LRSM(3)'="" S LRTXT=LRTXT_" ("_$S('LRSM(3):"negative",LRSM(3)=1:"positive",1:"?")_")"
103 D GLENTRY(LRTXT,LRP5,1)
104 Q
105GLENTRY(LRPR1,LRPR2,LRPR3) ;Write to global
106 ;LRPR1 = Text to be written to global
107 ;LRPR2 = Tab position
108 ;LRPR3 = 1 means start a new line. Othewise, write an current line.
109 S LRPR3=+$G(LRPR3)
110 D:LRPR3 NEWLN^LRAPUTL(LRPR1,LRPR2)
111 D:'LRPR3 GLBWRT^LRAPUTL(LRPR1,LRPR2)
112 Q
Note: See TracBrowser for help on using the repository browser.