source: WorldVistAEHR/trunk/r/HEALTH_SUMMARY-GMTS/GMTSLREE.m@ 1800

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

initial load of WorldVistAEHR

File size: 3.0 KB
RevLine 
[613]1GMTSLREE ; SLC/JER,KER - Electron Microscopy Extract ; 08/27/2002
2 ;;2.7;Health Summary;**3,28,56**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 525 ^LR(
6 ; DBIA 10011 ^DIWP
7 ;
8XTRCT ; Extract
9 N IX0,IX K ^TMP("LREM",$J) S IX=GMTS1
10 F IX0=1:0:MAX S IX=$O(^LR(LRDFN,"EM",IX)) Q:IX'>0!(IX>GMTS2) D APSET
11 K AP
12 Q
13APSET ; Sets ^TMP("LREM",$J
14 N ACC,CDT,DA,DIC,DIQ,DR,GMW,SN,X,YR
15 S CDT=$P(^LR(LRDFN,"EM",IX,0),U),ACC=$P(^(0),U,6)
16 I $S(+$P(^LR(LRDFN,"EM",IX,0),U)'>0:1,+$P(^(0),U,11)'>0:1,1:0) Q
17 I $D(ACC) S IX0=IX0+1
18 S X=CDT D REGDTM4^GMTSU S CDT=X K X
19 S ^TMP("LREM",$J,IX,0)=CDT_U_ACC
20 I $D(^LR(LRDFN,"EM",IX,.1)) S ^TMP("LREM",$J,IX,.1)="Site/Specimen"
21 S SN=0 F S SN=$O(^LR(LRDFN,"EM",IX,.1,SN)) Q:SN'>0 S ^TMP("LREM",$J,IX,.1,SN)=$P(^LR(LRDFN,"EM",IX,.1,SN,0),U)
22 I $D(^LR(LRDFN,"EM",IX,.2,0)),($P(^(0),U,3)]"") D CLHX
23 I $D(^LR(LRDFN,"EM",IX,1,0)),($P(^(0),U,3)]"") D GROSS
24 I $D(^LR(LRDFN,"EM",IX,1.1,0)),($P(^(0),U,3)]"") D MIC
25 I $D(^LR(LRDFN,"EM",IX,1.2,0)),($P(^(0),U,3)]"") D SUPPR
26 I $D(^LR(LRDFN,"EM",IX,1.4,0)),($P(^(0),U,3)]"") D SPDX
27 Q
28CLHX ; Brief Clinical History text
29 N LN
30 S ^TMP("LREM",$J,IX,.2)="Brief Clinical Hx"
31 K ^UTILITY($J,"W") S LN=0 F S LN=$O(^LR(LRDFN,"EM",IX,.2,LN)) Q:LN'>0 S X=$P(^LR(LRDFN,"EM",IX,.2,LN,0),U) D FORMAT
32 I $D(^UTILITY($J,"W")) F LN=1:1:^UTILITY($J,"W",3) S ^TMP("LREM",$J,IX,.2,LN)=^UTILITY($J,"W",DIWL,LN,0)
33 K ^UTILITY($J,"W")
34 Q
35GROSS ; Gross Description text
36 N LN
37 S ^TMP("LREM",$J,IX,1)="Gross Description"
38 K ^UTILITY($J,"W") S LN=0 F S LN=$O(^LR(LRDFN,"EM",IX,1,LN)) Q:LN'>0 S X=$P(^LR(LRDFN,"EM",IX,1,LN,0),U) D FORMAT
39 I $D(^UTILITY($J,"W")) F LN=1:1:^UTILITY($J,"W",3) S ^TMP("LREM",$J,IX,1,LN)=^UTILITY($J,"W",DIWL,LN,0)
40 K ^UTILITY($J,"W")
41 Q
42MIC ; Microscopic Exam/Diagnosis text
43 N LN
44 S ^TMP("LREM",$J,IX,1.1)="Microscopic Exam"
45 K ^UTILITY($J,"W") S LN=0 F S LN=$O(^LR(LRDFN,"EM",IX,1.1,LN)) Q:LN'>0 S X=$P(^LR(LRDFN,"EM",IX,1.1,LN,0),U) D FORMAT
46 I $D(^UTILITY($J,"W")) F LN=1:1:^UTILITY($J,"W",3) S ^TMP("LREM",$J,IX,1.1,LN)=^UTILITY($J,"W",DIWL,LN,0)
47 K ^UTILITY($J,"W")
48 Q
49SUPPR ; Supplementary Report date/text
50 N SP1 S ^TMP("LREM",$J,IX,1.2)="Supplementary Report"
51 S SP1=0
52 F S SP1=$O(^LR(LRDFN,"EM",IX,1.2,SP1)) Q:SP1'>0 D
53 . Q:+$P($G(^LR(LRDFN,"EM",IX,1.2,SP1,0)),U,2)'>0
54 . S ^TMP("LREM",$J,IX,1.2,SP1,0)=$P($G(^LR(LRDFN,"EM",IX,1.2,SP1,0)),U)
55 . K ^UTILITY($J,"W")
56 . S SR=0
57 . F S SR=$O(^LR(LRDFN,"EM",IX,1.2,SP1,1,SR)) Q:SR'>0 D
58 . . S X=$P($G(^LR(LRDFN,"EM",IX,1.2,SP1,1,SR,0)),U) D FORMAT
59 . I $D(^UTILITY($J,"W")) F LN=1:1:^UTILITY($J,"W",3) S ^TMP("LREM",$J,IX,1.2,SP1,LN)=^UTILITY($J,"W",DIWL,LN,0)
60 K ^UTILITY($J,"W")
61 Q
62SPDX ; Electron Microscopy DX text
63 N LN
64 S ^TMP("LREM",$J,IX,1.4)="Surgical Path Dx"
65 K ^UTILITY($J,"W") S LN=0 F S LN=$O(^LR(LRDFN,"EM",IX,1.4,LN)) Q:LN'>0 S X=$P(^LR(LRDFN,"EM",IX,1.4,LN,0),U) D FORMAT
66 I $D(^UTILITY($J,"W")) F LN=1:1:^UTILITY($J,"W",3) S ^TMP("LREM",$J,IX,1.4,LN)=^UTILITY($J,"W",DIWL,LN,0)
67 K ^UTILITY($J,"W")
68 Q
69FORMAT ; Format Text
70 S DIWF="N",DIWL=3,DIWR=78 D ^DIWP
71 Q
Note: See TracBrowser for help on using the repository browser.