- GMTSLRAE ; SLC/JER,KER - Surgical Pathology Extract ; 09/21/2001
- ;;2.7;Health Summary;**3,28,47**;Oct 20, 1995
- ;
- ; External References
- ; DBIA 525 ^LR( all fields
- ; DBIA 10060 ^VA(200, field .01 Read w/Fileman
- ; DBIA 2056 $$GET1^DIQ (file #200)
- ; DBIA 10015 EN^DIQ1 (file 63)
- ; DBIA 10011 ^DIWP
- ;
- XTRCT ; Extract Surgical Pathology
- N IX0,IX,DIWF,DIWL,DIWR K ^TMP("LRA",$J)
- S IX=GMTS1 F IX0=1:0:MAX S IX=$O(^LR(LRDFN,"SP",IX)) Q:IX'>0!(IX>GMTS2) D APSET
- K AP
- Q
- APSET ; Sets ^TMP("LRA",$J
- N ACC,CDT,DA,DIC,DIQ,DR,GMW,SN,X,YR,SPP
- S CDT=$P(^LR(LRDFN,"SP",IX,0),U),SPP=$P(^LR(LRDFN,"SP",IX,0),U,7),SPP=$$GET1^DIQ(200,(+SPP_","),.01),ACC=$P(^LR(LRDFN,"SP",IX,0),U,6)
- I $S(+$P(^LR(LRDFN,"SP",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("LRA",$J,IX,0)=CDT_U_ACC
- S:$L($G(SPP)) ^TMP("LRA",$J,IX,"SPP")=$G(SPP)
- I $D(^LR(LRDFN,"SP",IX,.1)) S ^TMP("LRA",$J,IX,.1)="Site/Specimen"
- S SN=0 F S SN=$O(^LR(LRDFN,"SP",IX,.1,SN)) Q:SN'>0 S ^TMP("LRA",$J,IX,.1,SN)=$P(^LR(LRDFN,"SP",IX,.1,SN,0),U)
- I $D(^LR(LRDFN,"SP",IX,.2,0)),($P(^(0),U,3)]"") D CLHX
- I $D(^LR(LRDFN,"SP",IX,1,0)),($P(^(0),U,3)]"") D GROSS
- I $D(^LR(LRDFN,"SP",IX,1.1,0)),($P(^(0),U,3)]"") D MIC
- I $D(^LR(LRDFN,"SP",IX,1.2,0)),($P(^(0),U,3)]"") D SUPPR
- I $D(^LR(LRDFN,"SP",IX,1.3,0)),($P(^(0),U,3)]"") D FROZ
- I $D(^LR(LRDFN,"SP",IX,1.4,0)),($P(^(0),U,3)]"") D SPDX
- Q
- MPD ; Morphology, Procedure data and Disease data (not used)
- S DIC=63,DIQ="AP",DIQ(0)="E",DR(63.08)=10,DR(63.12)=".01;1.5;3;4"
- S DR(63.16)=".01;1",DR(63.82)=.01,DR(63.17)=.01
- S DA(63.12)=0,DA(63.08)=IX
- F S DA(63.12)=$O(^LR(LRDFN,"SP",IX,2,DA(63.12))) Q:DA(63.12)="" D M,P,D
- Q
- M ; Morphology data
- N AP S DR=8,DA=LRDFN D EN^DIQ1 I $D(AP(63.12)) S ^TMP("LRA",$J,IX,2)="Topography Data",^(2,DA(63.12))=$S($D(AP(63.12,DA(63.12),.01,"E")):AP(63.12,DA(63.12),.01,"E"),1:"")
- S DA(63.16)=0 F S DA(63.16)=$O(^LR(LRDFN,"SP",IX,2,DA(63.12),2,DA(63.16))) Q:DA(63.16)="" D EN^DIQ1 I $D(AP(63.16)) D MSET
- K DA(63.16)
- Q
- MSET ; Save Morphology data
- S ^TMP("LRA",$J,IX,2,DA(63.12),2,DA(63.16))=$S($D(AP(63.16,DA(63.16),.01,"E")):AP(63.16,DA(63.16),.01,"E"),1:"") D
- . S DA(63.17)=0 F S DA(63.17)=$O(^LR(LRDFN,"SP",IX,2,DA(63.12),2,DA(63.16),1,DA(63.17))) Q:DA(63.17)="" D EN^DIQ1 I $D(AP(63.17)) D
- . . S ^TMP("LRA",$J,IX,2,DA(63.12),2,DA(63.16),1,DA(63.17))=$S($D(AP(63.17,DA(63.17),.01,"E")):AP(63.17,DA(63.17),.01,"E"),1:"")
- K DA(63.17)
- Q
- D ; Disease data
- S DA(63.15)=0 F S DA(63.15)=$O(^LR(LRDFN,"SP",IX,2,DA(63.12),1,DA(63.15))) Q:DA(63.15)="" D EN^DIQ1 I $D(AP(63.15)) D
- .S ^TMP("LRA",$J,IX,2,DA(63.12),1,DA(63.15))=$S($D(AP(63.15,DA(63.15),.01,"E")):AP(63.15,DA(63.15),.01,"E"),1:"")
- K DA(63.15)
- Q
- P ; Procedure data
- N AP
- S DA(63.82)=0
- S DA(63.82)=0 F S DR=8,DA=LRDFN,DA(63.82)=$O(^LR(LRDFN,"SP",IX,2,DA(63.12),4,DA(63.82))) Q:DA(63.82)="" D EN^DIQ1 I $D(AP(63.82)) D PSET
- K DA(63.82)
- Q
- PSET ; Save Procedure data
- S ^TMP("LRA",$J,IX,4)="Procedure Field"
- S ^TMP("LRA",$J,IX,2,DA(63.12),4,DA(63.82))=$S($D(AP(63.82,DA(63.82),.01,"E")):AP(63.82,DA(63.82),.01,"E"),1:"")
- Q
- CLHX ; Brief Clinical History text
- N LN
- S ^TMP("LRA",$J,IX,.2)="Brief Clinical Hx"
- K ^UTILITY($J,"W") S LN=0 F S LN=$O(^LR(LRDFN,"SP",IX,.2,LN)) Q:LN'>0 S X=^LR(LRDFN,"SP",IX,.2,LN,0) D FORMAT
- I $D(^UTILITY($J,"W")) F LN=1:1:^UTILITY($J,"W",3) S ^TMP("LRA",$J,IX,.2,LN)=^UTILITY($J,"W",DIWL,LN,0)
- K ^UTILITY($J,"W")
- Q
- GROSS ; Gross Description text
- N LN
- S ^TMP("LRA",$J,IX,1)="Gross Description"
- K ^UTILITY($J,"W") S LN=0 F S LN=$O(^LR(LRDFN,"SP",IX,1,LN)) Q:LN'>0 S X=$P(^LR(LRDFN,"SP",IX,1,LN,0),U) D FORMAT
- I $D(^UTILITY($J,"W")) F LN=1:1:^UTILITY($J,"W",3) S ^TMP("LRA",$J,IX,1,LN)=^UTILITY($J,"W",DIWL,LN,0)
- K ^UTILITY($J,"W")
- Q
- MIC ; Microscopic Exam/Diagnosis text
- N LN
- S ^TMP("LRA",$J,IX,1.1)="Microscopic Exam"
- K ^UTILITY($J,"W") S LN=0 F S LN=$O(^LR(LRDFN,"SP",IX,1.1,LN)) Q:LN'>0 S X=$P(^LR(LRDFN,"SP",IX,1.1,LN,0),U) D FORMAT
- I $D(^UTILITY($J,"W")) F LN=1:1:^UTILITY($J,"W",3) S ^TMP("LRA",$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("LRA",$J,IX,1.2)="Supplementary Report"
- S SP1=0 F S SP1=$O(^LR(LRDFN,"SP",IX,1.2,SP1)) Q:SP1'>0 D
- . Q:+$P($G(^LR(LRDFN,"SP",IX,1.2,SP1,0)),U,2)'>0
- . S ^TMP("LRA",$J,IX,1.2,SP1,0)=$P($G(^LR(LRDFN,"SP",IX,1.2,SP1,0)),U)
- . K ^UTILITY($J,"W")
- . S SR=0
- . F S SR=$O(^LR(LRDFN,"SP",IX,1.2,SP1,1,SR)) Q:SR'>0 D
- . . S X=$P($G(^LR(LRDFN,"SP",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("LRA",$J,IX,1.2,SP1,LN)=^UTILITY($J,"W",DIWL,LN,0)
- K ^UTILITY($J,"W")
- Q
- FROZ ; Frozen Section text
- N LN
- S ^TMP("LRA",$J,IX,1.3)="Frozen Section"
- K ^UTILITY($J,"W") S LN=0 F S LN=$O(^LR(LRDFN,"SP",IX,1.3,LN)) Q:LN'>0 S X=$P(^LR(LRDFN,"SP",IX,1.3,LN,0),U) D FORMAT
- I $D(^UTILITY($J,"W")) F LN=1:1:^UTILITY($J,"W",3) S ^TMP("LRA",$J,IX,1.3,LN)=^UTILITY($J,"W",DIWL,LN,0)
- K ^UTILITY($J,"W")
- Q
- SPDX ; Surgical Pathology DX text
- N LN
- S ^TMP("LRA",$J,IX,1.4)="Surgical Path Dx"
- K ^UTILITY($J,"W") S LN=0 F S LN=$O(^LR(LRDFN,"SP",IX,1.4,LN)) Q:LN'>0 S X=$P(^LR(LRDFN,"SP",IX,1.4,LN,0),U) D FORMAT
- I $D(^UTILITY($J,"W")) F LN=1:1:^UTILITY($J,"W",3) S ^TMP("LRA",$J,IX,1.4,LN)=^UTILITY($J,"W",DIWL,LN,0)
- K ^UTILITY($J,"W")
- Q
- FORMAT ; Format text - Left Margin 3/Right Margin 78
- S DIWF="N",DIWL=3,DIWR=78 D ^DIWP
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSLRAE 5558 printed Jan 18, 2025@02:58:52 Page 2
- GMTSLRAE ; SLC/JER,KER - Surgical Pathology Extract ; 09/21/2001
- +1 ;;2.7;Health Summary;**3,28,47**;Oct 20, 1995
- +2 ;
- +3 ; External References
- +4 ; DBIA 525 ^LR( all fields
- +5 ; DBIA 10060 ^VA(200, field .01 Read w/Fileman
- +6 ; DBIA 2056 $$GET1^DIQ (file #200)
- +7 ; DBIA 10015 EN^DIQ1 (file 63)
- +8 ; DBIA 10011 ^DIWP
- +9 ;
- XTRCT ; Extract Surgical Pathology
- +1 NEW IX0,IX,DIWF,DIWL,DIWR
- KILL ^TMP("LRA",$JOB)
- +2 SET IX=GMTS1
- FOR IX0=1:0:MAX
- SET IX=$ORDER(^LR(LRDFN,"SP",IX))
- if IX'>0!(IX>GMTS2)
- QUIT
- DO APSET
- +3 KILL AP
- +4 QUIT
- APSET ; Sets ^TMP("LRA",$J
- +1 NEW ACC,CDT,DA,DIC,DIQ,DR,GMW,SN,X,YR,SPP
- +2 SET CDT=$PIECE(^LR(LRDFN,"SP",IX,0),U)
- SET SPP=$PIECE(^LR(LRDFN,"SP",IX,0),U,7)
- SET SPP=$$GET1^DIQ(200,(+SPP_","),.01)
- SET ACC=$PIECE(^LR(LRDFN,"SP",IX,0),U,6)
- +3 IF $SELECT(+$PIECE(^LR(LRDFN,"SP",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("LRA",$JOB,IX,0)=CDT_U_ACC
- +7 if $LENGTH($GET(SPP))
- SET ^TMP("LRA",$JOB,IX,"SPP")=$GET(SPP)
- +8 IF $DATA(^LR(LRDFN,"SP",IX,.1))
- SET ^TMP("LRA",$JOB,IX,.1)="Site/Specimen"
- +9 SET SN=0
- FOR
- SET SN=$ORDER(^LR(LRDFN,"SP",IX,.1,SN))
- if SN'>0
- QUIT
- SET ^TMP("LRA",$JOB,IX,.1,SN)=$PIECE(^LR(LRDFN,"SP",IX,.1,SN,0),U)
- +10 IF $DATA(^LR(LRDFN,"SP",IX,.2,0))
- IF ($PIECE(^(0),U,3)]"")
- DO CLHX
- +11 IF $DATA(^LR(LRDFN,"SP",IX,1,0))
- IF ($PIECE(^(0),U,3)]"")
- DO GROSS
- +12 IF $DATA(^LR(LRDFN,"SP",IX,1.1,0))
- IF ($PIECE(^(0),U,3)]"")
- DO MIC
- +13 IF $DATA(^LR(LRDFN,"SP",IX,1.2,0))
- IF ($PIECE(^(0),U,3)]"")
- DO SUPPR
- +14 IF $DATA(^LR(LRDFN,"SP",IX,1.3,0))
- IF ($PIECE(^(0),U,3)]"")
- DO FROZ
- +15 IF $DATA(^LR(LRDFN,"SP",IX,1.4,0))
- IF ($PIECE(^(0),U,3)]"")
- DO SPDX
- +16 QUIT
- MPD ; Morphology, Procedure data and Disease data (not used)
- +1 SET DIC=63
- SET DIQ="AP"
- SET DIQ(0)="E"
- SET DR(63.08)=10
- SET DR(63.12)=".01;1.5;3;4"
- +2 SET DR(63.16)=".01;1"
- SET DR(63.82)=.01
- SET DR(63.17)=.01
- +3 SET DA(63.12)=0
- SET DA(63.08)=IX
- +4 FOR
- SET DA(63.12)=$ORDER(^LR(LRDFN,"SP",IX,2,DA(63.12)))
- if DA(63.12)=""
- QUIT
- DO M
- DO P
- DO D
- +5 QUIT
- M ; Morphology data
- +1 NEW AP
- SET DR=8
- SET DA=LRDFN
- DO EN^DIQ1
- IF $DATA(AP(63.12))
- SET ^TMP("LRA",$JOB,IX,2)="Topography Data"
- SET ^(2,DA(63.12))=$SELECT($DATA(AP(63.12,DA(63.12),.01,"E")):AP(63.12,DA(63.12),.01,"E"),1:"")
- +2 SET DA(63.16)=0
- FOR
- SET DA(63.16)=$ORDER(^LR(LRDFN,"SP",IX,2,DA(63.12),2,DA(63.16)))
- if DA(63.16)=""
- QUIT
- DO EN^DIQ1
- IF $DATA(AP(63.16))
- DO MSET
- +3 KILL DA(63.16)
- +4 QUIT
- MSET ; Save Morphology data
- +1 SET ^TMP("LRA",$JOB,IX,2,DA(63.12),2,DA(63.16))=$SELECT($DATA(AP(63.16,DA(63.16),.01,"E")):AP(63.16,DA(63.16),.01,"E"),1:"")
- Begin DoDot:1
- +2 SET DA(63.17)=0
- FOR
- SET DA(63.17)=$ORDER(^LR(LRDFN,"SP",IX,2,DA(63.12),2,DA(63.16),1,DA(63.17)))
- if DA(63.17)=""
- QUIT
- DO EN^DIQ1
- IF $DATA(AP(63.17))
- Begin DoDot:2
- +3 SET ^TMP("LRA",$JOB,IX,2,DA(63.12),2,DA(63.16),1,DA(63.17))=$SELECT($DATA(AP(63.17,DA(63.17),.01,"E")):AP(63.17,DA(63.17),.01,"E"),1:"")
- End DoDot:2
- End DoDot:1
- +4 KILL DA(63.17)
- +5 QUIT
- D ; Disease data
- +1 SET DA(63.15)=0
- FOR
- SET DA(63.15)=$ORDER(^LR(LRDFN,"SP",IX,2,DA(63.12),1,DA(63.15)))
- if DA(63.15)=""
- QUIT
- DO EN^DIQ1
- IF $DATA(AP(63.15))
- Begin DoDot:1
- +2 SET ^TMP("LRA",$JOB,IX,2,DA(63.12),1,DA(63.15))=$SELECT($DATA(AP(63.15,DA(63.15),.01,"E")):AP(63.15,DA(63.15),.01,"E"),1:"")
- End DoDot:1
- +3 KILL DA(63.15)
- +4 QUIT
- P ; Procedure data
- +1 NEW AP
- +2 SET DA(63.82)=0
- +3 SET DA(63.82)=0
- FOR
- SET DR=8
- SET DA=LRDFN
- SET DA(63.82)=$ORDER(^LR(LRDFN,"SP",IX,2,DA(63.12),4,DA(63.82)))
- if DA(63.82)=""
- QUIT
- DO EN^DIQ1
- IF $DATA(AP(63.82))
- DO PSET
- +4 KILL DA(63.82)
- +5 QUIT
- PSET ; Save Procedure data
- +1 SET ^TMP("LRA",$JOB,IX,4)="Procedure Field"
- +2 SET ^TMP("LRA",$JOB,IX,2,DA(63.12),4,DA(63.82))=$SELECT($DATA(AP(63.82,DA(63.82),.01,"E")):AP(63.82,DA(63.82),.01,"E"),1:"")
- +3 QUIT
- CLHX ; Brief Clinical History text
- +1 NEW LN
- +2 SET ^TMP("LRA",$JOB,IX,.2)="Brief Clinical Hx"
- +3 KILL ^UTILITY($JOB,"W")
- SET LN=0
- FOR
- SET LN=$ORDER(^LR(LRDFN,"SP",IX,.2,LN))
- if LN'>0
- QUIT
- SET X=^LR(LRDFN,"SP",IX,.2,LN,0)
- DO FORMAT
- +4 IF $DATA(^UTILITY($JOB,"W"))
- FOR LN=1:1:^UTILITY($JOB,"W",3)
- SET ^TMP("LRA",$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("LRA",$JOB,IX,1)="Gross Description"
- +3 KILL ^UTILITY($JOB,"W")
- SET LN=0
- FOR
- SET LN=$ORDER(^LR(LRDFN,"SP",IX,1,LN))
- if LN'>0
- QUIT
- SET X=$PIECE(^LR(LRDFN,"SP",IX,1,LN,0),U)
- DO FORMAT
- +4 IF $DATA(^UTILITY($JOB,"W"))
- FOR LN=1:1:^UTILITY($JOB,"W",3)
- SET ^TMP("LRA",$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("LRA",$JOB,IX,1.1)="Microscopic Exam"
- +3 KILL ^UTILITY($JOB,"W")
- SET LN=0
- FOR
- SET LN=$ORDER(^LR(LRDFN,"SP",IX,1.1,LN))
- if LN'>0
- QUIT
- SET X=$PIECE(^LR(LRDFN,"SP",IX,1.1,LN,0),U)
- DO FORMAT
- +4 IF $DATA(^UTILITY($JOB,"W"))
- FOR LN=1:1:^UTILITY($JOB,"W",3)
- SET ^TMP("LRA",$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("LRA",$JOB,IX,1.2)="Supplementary Report"
- +2 SET SP1=0
- FOR
- SET SP1=$ORDER(^LR(LRDFN,"SP",IX,1.2,SP1))
- if SP1'>0
- QUIT
- Begin DoDot:1
- +3 if +$PIECE($GET(^LR(LRDFN,"SP",IX,1.2,SP1,0)),U,2)'>0
- QUIT
- +4 SET ^TMP("LRA",$JOB,IX,1.2,SP1,0)=$PIECE($GET(^LR(LRDFN,"SP",IX,1.2,SP1,0)),U)
- +5 KILL ^UTILITY($JOB,"W")
- +6 SET SR=0
- +7 FOR
- SET SR=$ORDER(^LR(LRDFN,"SP",IX,1.2,SP1,1,SR))
- if SR'>0
- QUIT
- Begin DoDot:2
- +8 SET X=$PIECE($GET(^LR(LRDFN,"SP",IX,1.2,SP1,1,SR,0)),U)
- DO FORMAT
- End DoDot:2
- +9 IF $DATA(^UTILITY($JOB,"W"))
- FOR LN=1:1:^UTILITY($JOB,"W",3)
- SET ^TMP("LRA",$JOB,IX,1.2,SP1,LN)=^UTILITY($JOB,"W",DIWL,LN,0)
- End DoDot:1
- +10 KILL ^UTILITY($JOB,"W")
- +11 QUIT
- FROZ ; Frozen Section text
- +1 NEW LN
- +2 SET ^TMP("LRA",$JOB,IX,1.3)="Frozen Section"
- +3 KILL ^UTILITY($JOB,"W")
- SET LN=0
- FOR
- SET LN=$ORDER(^LR(LRDFN,"SP",IX,1.3,LN))
- if LN'>0
- QUIT
- SET X=$PIECE(^LR(LRDFN,"SP",IX,1.3,LN,0),U)
- DO FORMAT
- +4 IF $DATA(^UTILITY($JOB,"W"))
- FOR LN=1:1:^UTILITY($JOB,"W",3)
- SET ^TMP("LRA",$JOB,IX,1.3,LN)=^UTILITY($JOB,"W",DIWL,LN,0)
- +5 KILL ^UTILITY($JOB,"W")
- +6 QUIT
- SPDX ; Surgical Pathology DX text
- +1 NEW LN
- +2 SET ^TMP("LRA",$JOB,IX,1.4)="Surgical Path Dx"
- +3 KILL ^UTILITY($JOB,"W")
- SET LN=0
- FOR
- SET LN=$ORDER(^LR(LRDFN,"SP",IX,1.4,LN))
- if LN'>0
- QUIT
- SET X=$PIECE(^LR(LRDFN,"SP",IX,1.4,LN,0),U)
- DO FORMAT
- +4 IF $DATA(^UTILITY($JOB,"W"))
- FOR LN=1:1:^UTILITY($JOB,"W",3)
- SET ^TMP("LRA",$JOB,IX,1.4,LN)=^UTILITY($JOB,"W",DIWL,LN,0)
- +5 KILL ^UTILITY($JOB,"W")
- +6 QUIT
- FORMAT ; Format text - Left Margin 3/Right Margin 78
- +1 SET DIWF="N"
- SET DIWL=3
- SET DIWR=78
- DO ^DIWP
- +2 QUIT