GMTSLREE ; SLC/JER,KER - Electron Microscopy Extract ; 08/27/2002
;;2.7;Health Summary;**3,28,56**;Oct 20, 1995
;
; External References
; DBIA 525 ^LR(
; DBIA 10011 ^DIWP
;
XTRCT ; Extract
N IX0,IX K ^TMP("LREM",$J) S IX=GMTS1
F IX0=1:0:MAX S IX=$O(^LR(LRDFN,"EM",IX)) Q:IX'>0!(IX>GMTS2) D APSET
K AP
Q
APSET ; Sets ^TMP("LREM",$J
N ACC,CDT,DA,DIC,DIQ,DR,GMW,SN,X,YR
S CDT=$P(^LR(LRDFN,"EM",IX,0),U),ACC=$P(^(0),U,6)
I $S(+$P(^LR(LRDFN,"EM",IX,0),U)'>0:1,+$P(^(0),U,11)'>0:1,1:0) Q
I $D(ACC) S IX0=IX0+1
S X=CDT D REGDTM4^GMTSU S CDT=X K X
S ^TMP("LREM",$J,IX,0)=CDT_U_ACC
I $D(^LR(LRDFN,"EM",IX,.1)) S ^TMP("LREM",$J,IX,.1)="Site/Specimen"
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)
I $D(^LR(LRDFN,"EM",IX,.2,0)),($P(^(0),U,3)]"") D CLHX
I $D(^LR(LRDFN,"EM",IX,1,0)),($P(^(0),U,3)]"") D GROSS
I $D(^LR(LRDFN,"EM",IX,1.1,0)),($P(^(0),U,3)]"") D MIC
I $D(^LR(LRDFN,"EM",IX,1.2,0)),($P(^(0),U,3)]"") D SUPPR
I $D(^LR(LRDFN,"EM",IX,1.4,0)),($P(^(0),U,3)]"") D SPDX
Q
CLHX ; Brief Clinical History text
N LN
S ^TMP("LREM",$J,IX,.2)="Brief Clinical Hx"
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
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)
K ^UTILITY($J,"W")
Q
GROSS ; Gross Description text
N LN
S ^TMP("LREM",$J,IX,1)="Gross Description"
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
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)
K ^UTILITY($J,"W")
Q
MIC ; Microscopic Exam/Diagnosis text
N LN
S ^TMP("LREM",$J,IX,1.1)="Microscopic Exam"
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
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)
K ^UTILITY($J,"W")
Q
SUPPR ; Supplementary Report date/text
N SP1 S ^TMP("LREM",$J,IX,1.2)="Supplementary Report"
S SP1=0
F S SP1=$O(^LR(LRDFN,"EM",IX,1.2,SP1)) Q:SP1'>0 D
. Q:+$P($G(^LR(LRDFN,"EM",IX,1.2,SP1,0)),U,2)'>0
. S ^TMP("LREM",$J,IX,1.2,SP1,0)=$P($G(^LR(LRDFN,"EM",IX,1.2,SP1,0)),U)
. K ^UTILITY($J,"W")
. S SR=0
. F S SR=$O(^LR(LRDFN,"EM",IX,1.2,SP1,1,SR)) Q:SR'>0 D
. . S X=$P($G(^LR(LRDFN,"EM",IX,1.2,SP1,1,SR,0)),U) D FORMAT
. 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)
K ^UTILITY($J,"W")
Q
SPDX ; Electron Microscopy DX text
N LN
S ^TMP("LREM",$J,IX,1.4)="Surgical Path Dx"
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
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)
K ^UTILITY($J,"W")
Q
FORMAT ; Format Text
S DIWF="N",DIWL=3,DIWR=78 D ^DIWP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSLREE 3141 printed Dec 13, 2024@01:57:46 Page 2
GMTSLREE ; SLC/JER,KER - Electron Microscopy Extract ; 08/27/2002
+1 ;;2.7;Health Summary;**3,28,56**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 525 ^LR(
+5 ; DBIA 10011 ^DIWP
+6 ;
XTRCT ; Extract
+1 NEW IX0,IX
KILL ^TMP("LREM",$JOB)
SET IX=GMTS1
+2 FOR IX0=1:0:MAX
SET IX=$ORDER(^LR(LRDFN,"EM",IX))
if IX'>0!(IX>GMTS2)
QUIT
DO APSET
+3 KILL AP
+4 QUIT
APSET ; Sets ^TMP("LREM",$J
+1 NEW ACC,CDT,DA,DIC,DIQ,DR,GMW,SN,X,YR
+2 SET CDT=$PIECE(^LR(LRDFN,"EM",IX,0),U)
SET ACC=$PIECE(^(0),U,6)
+3 IF $SELECT(+$PIECE(^LR(LRDFN,"EM",IX,0),U)'>0:1,+$PIECE(^(0),U,11)'>0:1,1:0)
QUIT
+4 IF $DATA(ACC)
SET IX0=IX0+1
+5 SET X=CDT
DO REGDTM4^GMTSU
SET CDT=X
KILL X
+6 SET ^TMP("LREM",$JOB,IX,0)=CDT_U_ACC
+7 IF $DATA(^LR(LRDFN,"EM",IX,.1))
SET ^TMP("LREM",$JOB,IX,.1)="Site/Specimen"
+8 SET SN=0
FOR
SET SN=$ORDER(^LR(LRDFN,"EM",IX,.1,SN))
if SN'>0
QUIT
SET ^TMP("LREM",$JOB,IX,.1,SN)=$PIECE(^LR(LRDFN,"EM",IX,.1,SN,0),U)
+9 IF $DATA(^LR(LRDFN,"EM",IX,.2,0))
IF ($PIECE(^(0),U,3)]"")
DO CLHX
+10 IF $DATA(^LR(LRDFN,"EM",IX,1,0))
IF ($PIECE(^(0),U,3)]"")
DO GROSS
+11 IF $DATA(^LR(LRDFN,"EM",IX,1.1,0))
IF ($PIECE(^(0),U,3)]"")
DO MIC
+12 IF $DATA(^LR(LRDFN,"EM",IX,1.2,0))
IF ($PIECE(^(0),U,3)]"")
DO SUPPR
+13 IF $DATA(^LR(LRDFN,"EM",IX,1.4,0))
IF ($PIECE(^(0),U,3)]"")
DO SPDX
+14 QUIT
CLHX ; Brief Clinical History text
+1 NEW LN
+2 SET ^TMP("LREM",$JOB,IX,.2)="Brief Clinical Hx"
+3 KILL ^UTILITY($JOB,"W")
SET LN=0
FOR
SET LN=$ORDER(^LR(LRDFN,"EM",IX,.2,LN))
if LN'>0
QUIT
SET X=$PIECE(^LR(LRDFN,"EM",IX,.2,LN,0),U)
DO FORMAT
+4 IF $DATA(^UTILITY($JOB,"W"))
FOR LN=1:1:^UTILITY($JOB,"W",3)
SET ^TMP("LREM",$JOB,IX,.2,LN)=^UTILITY($JOB,"W",DIWL,LN,0)
+5 KILL ^UTILITY($JOB,"W")
+6 QUIT
GROSS ; Gross Description text
+1 NEW LN
+2 SET ^TMP("LREM",$JOB,IX,1)="Gross Description"
+3 KILL ^UTILITY($JOB,"W")
SET LN=0
FOR
SET LN=$ORDER(^LR(LRDFN,"EM",IX,1,LN))
if LN'>0
QUIT
SET X=$PIECE(^LR(LRDFN,"EM",IX,1,LN,0),U)
DO FORMAT
+4 IF $DATA(^UTILITY($JOB,"W"))
FOR LN=1:1:^UTILITY($JOB,"W",3)
SET ^TMP("LREM",$JOB,IX,1,LN)=^UTILITY($JOB,"W",DIWL,LN,0)
+5 KILL ^UTILITY($JOB,"W")
+6 QUIT
MIC ; Microscopic Exam/Diagnosis text
+1 NEW LN
+2 SET ^TMP("LREM",$JOB,IX,1.1)="Microscopic Exam"
+3 KILL ^UTILITY($JOB,"W")
SET LN=0
FOR
SET LN=$ORDER(^LR(LRDFN,"EM",IX,1.1,LN))
if LN'>0
QUIT
SET X=$PIECE(^LR(LRDFN,"EM",IX,1.1,LN,0),U)
DO FORMAT
+4 IF $DATA(^UTILITY($JOB,"W"))
FOR LN=1:1:^UTILITY($JOB,"W",3)
SET ^TMP("LREM",$JOB,IX,1.1,LN)=^UTILITY($JOB,"W",DIWL,LN,0)
+5 KILL ^UTILITY($JOB,"W")
+6 QUIT
SUPPR ; Supplementary Report date/text
+1 NEW SP1
SET ^TMP("LREM",$JOB,IX,1.2)="Supplementary Report"
+2 SET SP1=0
+3 FOR
SET SP1=$ORDER(^LR(LRDFN,"EM",IX,1.2,SP1))
if SP1'>0
QUIT
Begin DoDot:1
+4 if +$PIECE($GET(^LR(LRDFN,"EM",IX,1.2,SP1,0)),U,2)'>0
QUIT
+5 SET ^TMP("LREM",$JOB,IX,1.2,SP1,0)=$PIECE($GET(^LR(LRDFN,"EM",IX,1.2,SP1,0)),U)
+6 KILL ^UTILITY($JOB,"W")
+7 SET SR=0
+8 FOR
SET SR=$ORDER(^LR(LRDFN,"EM",IX,1.2,SP1,1,SR))
if SR'>0
QUIT
Begin DoDot:2
+9 SET X=$PIECE($GET(^LR(LRDFN,"EM",IX,1.2,SP1,1,SR,0)),U)
DO FORMAT
End DoDot:2
+10 IF $DATA(^UTILITY($JOB,"W"))
FOR LN=1:1:^UTILITY($JOB,"W",3)
SET ^TMP("LREM",$JOB,IX,1.2,SP1,LN)=^UTILITY($JOB,"W",DIWL,LN,0)
End DoDot:1
+11 KILL ^UTILITY($JOB,"W")
+12 QUIT
SPDX ; Electron Microscopy DX text
+1 NEW LN
+2 SET ^TMP("LREM",$JOB,IX,1.4)="Surgical Path Dx"
+3 KILL ^UTILITY($JOB,"W")
SET LN=0
FOR
SET LN=$ORDER(^LR(LRDFN,"EM",IX,1.4,LN))
if LN'>0
QUIT
SET X=$PIECE(^LR(LRDFN,"EM",IX,1.4,LN,0),U)
DO FORMAT
+4 IF $DATA(^UTILITY($JOB,"W"))
FOR LN=1:1:^UTILITY($JOB,"W",3)
SET ^TMP("LREM",$JOB,IX,1.4,LN)=^UTILITY($JOB,"W",DIWL,LN,0)
+5 KILL ^UTILITY($JOB,"W")
+6 QUIT
FORMAT ; Format Text
+1 SET DIWF="N"
SET DIWL=3
SET DIWR=78
DO ^DIWP
+2 QUIT
