GMTSLRA ; SLC/JER,KER - Surgical Pathology Component ; 09/21/2001
;;2.7;Health Summary;**28,47**;Oct 20, 1995
;
; External References
; DBIA 10035 ^DPT( field 63 Read w/Fileman
; DBIA 2056 $$GET1^DIQ (file 2)
;
MAIN ; Surgical Pathology
N GMI,MAX,LRDFN,IX,X,SP,IX0
S LRDFN=+($$GET1^DIQ(2,(+($G(DFN))_","),63,"I")) Q:+LRDFN=0
S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:999) D ^GMTSLRAE
I '$D(^TMP("LRA",$J)) Q
S IX=0 F GMI=1:1:MAX S IX=$O(^TMP("LRA",$J,IX)) Q:$D(GMTSQIT) Q:IX'>0 D Q:$D(GMTSQIT)
. D:GMI>1 CKP^GMTSUP Q:$D(GMTSQIT) W:GMI>1&('GMTSNPG) ! D
. . S IX0="" F S IX0=$O(^TMP("LRA",$J,IX,IX0)) Q:IX0=""!(IX0?1A) D
. . . S X=^TMP("LRA",$J,IX,IX0)
. . . S SP=$G(^TMP("LRA",$J,IX,"SPP")) D WRT
. . I $D(^TMP("LRA",$J,IX,1.2)) D SUPPR
K ^TMP("LRA",$J)
Q
WRT ; Writes Surgical Pathology Record
N IX1,GMJ
I IX0=0 D Q
. D CKP^GMTSUP Q:$D(GMTSQIT)
. W ?8,"Collected:",?19,$P(X,U),?31,"Acc:",?36,$P(X,U,2),!
. Q:'$L($G(SP)) D CKP^GMTSUP Q:$D(GMTSQIT)
. W "Surgeon/Physician:",?19,$G(SP),!
I IX0=.1 D WRTSPC Q
I $S(IX0=.2:1,IX0=1:1,IX0=1.1:1,IX0=1.3:1,IX0=1.4:1,1:0) D TEXT Q
I IX0=2 S IX1=0 F S IX1=$O(^TMP("LRA",$J,IX,IX0,IX1)) Q:IX1'>0 S X=^(IX1) D WRTTM,WRTP
Q
WRTSPC ; Writes Specimen field entries
N GMS
D CKP^GMTSUP Q:$D(GMTSQIT) W ?9,"Specimen:"
S GMS=0
F S GMS=$O(^TMP("LRA",$J,IX,.1,GMS)) Q:GMS'>0 D CKP^GMTSUP Q:$D(GMTSQIT) W ?19,^TMP("LRA",$J,IX,.1,GMS),!
Q
TEXT ; Handles GROSS DESCRIPTION & MICROSCOPIC EXAM/DX Print
N LN,GMTSLN,GMTSLNI
D CKP^GMTSUP Q:$D(GMTSQIT) W ?(17-$L(X)),X_":",!
S LN=0
F S LN=$O(^TMP("LRA",$J,IX,IX0,LN)) Q:LN'>0 S GMTSLN=^(LN) D
.I $L(GMTSLN)>78 S GMTSLN=$$WRAP^GMTSORC(GMTSLN,78)
.D CKP^GMTSUP Q:$D(GMTSQIT) W $P(GMTSLN,"|"),! D
..F GMTSLNI=2:1:$L(GMTSLN,"|") D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMTSLN,"|",GMTSLNI)]"" $P(GMTSLN,"|",GMTSLNI),!
Q
SUPPR ; Writes Supplementary Report
N GMTSR,SRDATE,GMTSRL,GMTSRLI,X
S IX1=0
F S IX1=$O(^TMP("LRA",$J,IX,1.2,IX1)) Q:IX1'>0 D CKP^GMTSUP Q:$D(GMTSQIT) S SRDATE=^TMP("LRA",$J,IX,1.2,IX1,0) S X=SRDATE D REGDTM4^GMTSU W "Supplementary Rpt: ",X,! D
.S GMTSR=0
.F S GMTSR=$O(^TMP("LRA",$J,IX,1.2,IX1,GMTSR)) Q:GMTSR'>0 S GMTSRL=^(GMTSR) D
..I $L(GMTSRL)>78 S GMTSRL=$$WRAP^GMTSORC(GMTSRL,78)
..W $P(GMTSRL,"|"),! D
...F GMTSRLI=2:1:$L(GMTSRL,"|") D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMTSRL,"|",GMTSRLI)]"" $P(GMTSRL,"|",GMTSRLI),!
Q
WRTTM ; Writes Topography and Morphology
N GMT,GMD,GME
D CKP^GMTSUP Q:$D(GMTSQIT) W ?7,"Topography:",?19,$P(X,U),!
I $O(^TMP("LRA",$J,IX,IX0,IX1,1,0)) D CKP^GMTSUP Q:$D(GMTSQIT)
S GMD=0
F S GMD=$O(^TMP("LRA",$J,IX,IX0,IX1,1,GMD)) Q:GMD'>0 W:GMD=1 ?9,"Disease:" W ?21,^TMP("LRA",$J,IX,IX0,IX1,1,GMD),! Q
I $O(^TMP("LRA",$J,IX,IX0,IX1,2,0)) D CKP^GMTSUP Q:$D(GMTSQIT)
S GMT=0
F S GMT=$O(^TMP("LRA",$J,IX,IX0,IX1,2,GMT)) Q:GMT'>0 D
.I GMT'=4 D CKP^GMTSUP Q:$D(GMTSQIT)
.I W ?7,"Morphology:",?21,^TMP("LRA",$J,IX,IX0,IX1,2,GMT),! D Q
..S GME=0
..F S GME=$O(^TMP("LRA",$J,IX,IX0,IX1,2,GMT,1,GME)) Q:GME'>0 D
...D CKP^GMTSUP Q:$D(GMTSQIT) W:GME=1 ?9,"Etiology:" W ?23,^TMP("LRA",$J,IX,IX0,IX1,2,GMT,1,GME),! Q
Q
WRTP ; Writes Procedure field
N GMQ,GMK
I $O(^TMP("LRA",$J,IX,IX0,IX1,4,0)) D CKP^GMTSUP Q:$D(GMTSQIT) W ?7,"Procedures:"
S GMT=0
F S GMT=$O(^TMP("LRA",$J,IX,IX0,IX1,4,GMT)) Q:GMT'>0 D
.S GMQ=$P(^TMP("LRA",$J,IX,IX0,IX1,4,GMT),U)
.I $L(GMQ)>56 S GMQ=$$WRAP^GMTSORC(GMQ,56)
.D CKP^GMTSUP Q:$D(GMTSQIT) W ?21,$P(GMQ,"|"),! D
..F GMK=2:1:$L(GMQ,"|") D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMQ,"|",GMK)]"" ?23,$P(GMQ,"|",GMK),!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSLRA 3652 printed Nov 22, 2024@17:07:46 Page 2
GMTSLRA ; SLC/JER,KER - Surgical Pathology Component ; 09/21/2001
+1 ;;2.7;Health Summary;**28,47**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 10035 ^DPT( field 63 Read w/Fileman
+5 ; DBIA 2056 $$GET1^DIQ (file 2)
+6 ;
MAIN ; Surgical Pathology
+1 NEW GMI,MAX,LRDFN,IX,X,SP,IX0
+2 SET LRDFN=+($$GET1^DIQ(2,(+($GET(DFN))_","),63,"I"))
if +LRDFN=0
QUIT
+3 SET MAX=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:999)
DO ^GMTSLRAE
+4 IF '$DATA(^TMP("LRA",$JOB))
QUIT
+5 SET IX=0
FOR GMI=1:1:MAX
SET IX=$ORDER(^TMP("LRA",$JOB,IX))
if $DATA(GMTSQIT)
QUIT
if IX'>0
QUIT
Begin DoDot:1
+6 if GMI>1
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if GMI>1&('GMTSNPG)
WRITE !
Begin DoDot:2
+7 SET IX0=""
FOR
SET IX0=$ORDER(^TMP("LRA",$JOB,IX,IX0))
if IX0=""!(IX0?1A)
QUIT
Begin DoDot:3
+8 SET X=^TMP("LRA",$JOB,IX,IX0)
+9 SET SP=$GET(^TMP("LRA",$JOB,IX,"SPP"))
DO WRT
End DoDot:3
+10 IF $DATA(^TMP("LRA",$JOB,IX,1.2))
DO SUPPR
End DoDot:2
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+11 KILL ^TMP("LRA",$JOB)
+12 QUIT
WRT ; Writes Surgical Pathology Record
+1 NEW IX1,GMJ
+2 IF IX0=0
Begin DoDot:1
+3 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+4 WRITE ?8,"Collected:",?19,$PIECE(X,U),?31,"Acc:",?36,$PIECE(X,U,2),!
+5 if '$LENGTH($GET(SP))
QUIT
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+6 WRITE "Surgeon/Physician:",?19,$GET(SP),!
End DoDot:1
QUIT
+7 IF IX0=.1
DO WRTSPC
QUIT
+8 IF $SELECT(IX0=.2:1,IX0=1:1,IX0=1.1:1,IX0=1.3:1,IX0=1.4:1,1:0)
DO TEXT
QUIT
+9 IF IX0=2
SET IX1=0
FOR
SET IX1=$ORDER(^TMP("LRA",$JOB,IX,IX0,IX1))
if IX1'>0
QUIT
SET X=^(IX1)
DO WRTTM
DO WRTP
+10 QUIT
WRTSPC ; Writes Specimen field entries
+1 NEW GMS
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?9,"Specimen:"
+3 SET GMS=0
+4 FOR
SET GMS=$ORDER(^TMP("LRA",$JOB,IX,.1,GMS))
if GMS'>0
QUIT
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?19,^TMP("LRA",$JOB,IX,.1,GMS),!
+5 QUIT
TEXT ; Handles GROSS DESCRIPTION & MICROSCOPIC EXAM/DX Print
+1 NEW LN,GMTSLN,GMTSLNI
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?(17-$LENGTH(X)),X_":",!
+3 SET LN=0
+4 FOR
SET LN=$ORDER(^TMP("LRA",$JOB,IX,IX0,LN))
if LN'>0
QUIT
SET GMTSLN=^(LN)
Begin DoDot:1
+5 IF $LENGTH(GMTSLN)>78
SET GMTSLN=$$WRAP^GMTSORC(GMTSLN,78)
+6 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE $PIECE(GMTSLN,"|"),!
Begin DoDot:2
+7 FOR GMTSLNI=2:1:$LENGTH(GMTSLN,"|")
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if $PIECE(GMTSLN,"|",GMTSLNI)]""
WRITE $PIECE(GMTSLN,"|",GMTSLNI),!
End DoDot:2
End DoDot:1
+8 QUIT
SUPPR ; Writes Supplementary Report
+1 NEW GMTSR,SRDATE,GMTSRL,GMTSRLI,X
+2 SET IX1=0
+3 FOR
SET IX1=$ORDER(^TMP("LRA",$JOB,IX,1.2,IX1))
if IX1'>0
QUIT
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
SET SRDATE=^TMP("LRA",$JOB,IX,1.2,IX1,0)
SET X=SRDATE
DO REGDTM4^GMTSU
WRITE "Supplementary Rpt: ",X,!
Begin DoDot:1
+4 SET GMTSR=0
+5 FOR
SET GMTSR=$ORDER(^TMP("LRA",$JOB,IX,1.2,IX1,GMTSR))
if GMTSR'>0
QUIT
SET GMTSRL=^(GMTSR)
Begin DoDot:2
+6 IF $LENGTH(GMTSRL)>78
SET GMTSRL=$$WRAP^GMTSORC(GMTSRL,78)
+7 WRITE $PIECE(GMTSRL,"|"),!
Begin DoDot:3
+8 FOR GMTSRLI=2:1:$LENGTH(GMTSRL,"|")
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if $PIECE(GMTSRL,"|",GMTSRLI)]""
WRITE $PIECE(GMTSRL,"|",GMTSRLI),!
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
WRTTM ; Writes Topography and Morphology
+1 NEW GMT,GMD,GME
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?7,"Topography:",?19,$PIECE(X,U),!
+3 IF $ORDER(^TMP("LRA",$JOB,IX,IX0,IX1,1,0))
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+4 SET GMD=0
+5 FOR
SET GMD=$ORDER(^TMP("LRA",$JOB,IX,IX0,IX1,1,GMD))
if GMD'>0
QUIT
if GMD=1
WRITE ?9,"Disease:"
WRITE ?21,^TMP("LRA",$JOB,IX,IX0,IX1,1,GMD),!
QUIT
+6 IF $ORDER(^TMP("LRA",$JOB,IX,IX0,IX1,2,0))
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+7 SET GMT=0
+8 FOR
SET GMT=$ORDER(^TMP("LRA",$JOB,IX,IX0,IX1,2,GMT))
if GMT'>0
QUIT
Begin DoDot:1
+9 IF GMT'=4
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+10 IF $TEST
WRITE ?7,"Morphology:",?21,^TMP("LRA",$JOB,IX,IX0,IX1,2,GMT),!
Begin DoDot:2
+11 SET GME=0
+12 FOR
SET GME=$ORDER(^TMP("LRA",$JOB,IX,IX0,IX1,2,GMT,1,GME))
if GME'>0
QUIT
Begin DoDot:3
+13 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if GME=1
WRITE ?9,"Etiology:"
WRITE ?23,^TMP("LRA",$JOB,IX,IX0,IX1,2,GMT,1,GME),!
QUIT
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+14 QUIT
WRTP ; Writes Procedure field
+1 NEW GMQ,GMK
+2 IF $ORDER(^TMP("LRA",$JOB,IX,IX0,IX1,4,0))
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?7,"Procedures:"
+3 SET GMT=0
+4 FOR
SET GMT=$ORDER(^TMP("LRA",$JOB,IX,IX0,IX1,4,GMT))
if GMT'>0
QUIT
Begin DoDot:1
+5 SET GMQ=$PIECE(^TMP("LRA",$JOB,IX,IX0,IX1,4,GMT),U)
+6 IF $LENGTH(GMQ)>56
SET GMQ=$$WRAP^GMTSORC(GMQ,56)
+7 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?21,$PIECE(GMQ,"|"),!
Begin DoDot:2
+8 FOR GMK=2:1:$LENGTH(GMQ,"|")
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if $PIECE(GMQ,"|",GMK)]""
WRITE ?23,$PIECE(GMQ,"|",GMK),!
End DoDot:2
End DoDot:1
+9 QUIT
