GMTSLRCP ; SLC/JER,KER - Cytopathology Comp Dvr ; 09/21/2001
;;2.7;Health Summary;**28,47**;Oct 20, 1995
;
; External References
; DBIA 525 ^LR( all fields
; DBIA 10035 ^DPT( field 63 Read w/Fileman
; DBIA 2056 $$GET1^DIQ (file 2)
;
MAIN ; Cytopathology
N GMI,IX,IX0,IX1,MAX,LRDFN
S LRDFN=+($$GET1^DIQ(2,(+($G(DFN))_","),63,"I")) Q:+LRDFN=0 Q:'$D(^LR(LRDFN))
S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:999) D ^GMTSLRPE
Q:'$D(^TMP("LRCY",$J)) S IX=""
F GMI=1:1:MAX S IX=$O(^TMP("LRCY",$J,IX)) Q:IX="" D Q:$D(GMTSQIT)
. D:GMI>1 CKP^GMTSUP Q:$D(GMTSQIT) W:GMI>1&'GMTSNPG ! S IX0=""
. F S IX0=$O(^TMP("LRCY",$J,IX,IX0)) Q:IX0="" D Q:$D(GMTSQIT)
. . D TRVRS
K ^TMP("LRCY",$J)
Q
TRVRS ; Traverses/Interprets ^TMP("LRCY",$J,
N GMS,SPEC
I IX0=0 D CKP^GMTSUP Q:$D(GMTSQIT) W ?8,"Collected:",?19,$P(^TMP("LRCY",$J,IX,IX0),U),?31,"Acc:",?36,$P(^TMP("LRCY",$J,IX,IX0),U,2),! Q
I IX0=1 D CKP^GMTSUP Q:$D(GMTSQIT) W ?9,"Specimen:" S GMS=0 F S GMS=$O(^TMP("LRCY",$J,IX,IX0,GMS)) Q:GMS'>0 D CKP^GMTSUP Q:$D(GMTSQIT) W ?19,^TMP("LRCY",$J,IX,IX0,GMS),!
I IX0=1,($P(^TMP("LRCY",$J,IX,IX0),U,2)'>0) D CKP^GMTSUP Q:$D(GMTSQIT) W ?18,"** REPORT NOT YET RELEASED **",!
Q:IX0=1 D @$E(IX0,1,2)
Q
AH ; Writes clinical history
N GMTSH,GMTSHL,GMTSHLI
D CKP^GMTSUP Q:$D(GMTSQIT) W !,"Brief Clinical Hx:",!
S GMTSH=0
F S GMTSH=$O(^TMP("LRCY",$J,IX,IX0,GMTSH)) Q:+GMTSH'>0 S GMTSHL=^(GMTSH) D
.I $L(GMTSHL)>78 S GMTSHL=$$WRAP^GMTSORC(GMTSHL,78)
.D CKP^GMTSUP Q:$D(GMTSQIT) W $P(GMTSHL,"|"),! D
..F GMTSHLI=2:1:$L(GMTSHL,"|") D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMTSHL,"|",GMTSHLI)]"" $P(GMTSHL,"|",GMTSHLI),!
Q
G ; Writes Gross Description
N GMTSG,GMTSGL,GMTSGLI
D CKP^GMTSUP Q:$D(GMTSQIT) W !,"Gross Description:",!
S GMTSG=0
F S GMTSG=$O(^TMP("LRCY",$J,IX,IX0,GMTSG)) Q:GMTSG'>0 S GMTSGL=^(GMTSG) D
.I $L(GMTSGL)>78 S GMTSGL=$$WRAP^GMTSORC(GMTSGL,78)
.D CKP^GMTSUP Q:$D(GMTSQIT) W $P(GMTSGL,"|"),! D
..F GMTSGLI=2:1:$L(GMTSGL,"|") D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMTSGL,"|",GMTSGLI)]"" $P(GMTSGL,"|",GMTSGLI),!
Q
MI ; Writes Microscopic exam/diagnosis field
N GMTSM,GMTSML,GMTSMLI
D CKP^GMTSUP Q:$D(GMTSQIT) W !,"Microscopic exam:",!
S GMTSM=0
F S GMTSM=$O(^TMP("LRCY",$J,IX,IX0,GMTSM)) Q:GMTSM'>0 S GMTSML=^(GMTSM) D
. I $L(GMTSML)>78 S GMTSML=$$WRAP^GMTSORC(GMTSML,78)
. D CKP^GMTSUP Q:$D(GMTSQIT) W $P(GMTSML,"|"),! D
. . F GMTSMLI=2:1:$L(GMTSML,"|") D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMTSML,"|",GMTSMLI)]"" $P(GMTSML,"|",GMTSMLI),!
Q
SR ; Writes Supplementary Reports
N GMTSLINE,GMTSL,GMTSR,SRDATE,X S IX1=0
F S IX1=$O(^TMP("LRCY",$J,IX,IX0,IX1)) Q:IX1'>0 D Q:$D(GMTSQIT)
. D CKP^GMTSUP Q:$D(GMTSQIT) S SRDATE=^TMP("LRCY",$J,IX,IX0,IX1,0)
. S X=SRDATE D REGDTM4^GMTSU W !,"Supplementary Rpt: ",X,!
. S GMTSR=0
. F S GMTSR=$O(^TMP("LRCY",$J,IX,IX0,IX1,GMTSR)) Q:GMTSR'>0 D Q:$D(GMTSQIT)
. . S GMTSLINE=^TMP("LRCY",$J,IX,IX0,IX1,GMTSR) I $L(GMTSLINE)>78 S GMTSLINE=$$WRAP^GMTSORC(GMTSLINE,78)
. . D CKP^GMTSUP Q:$D(GMTSQIT) W $P(GMTSLINE,"|"),! D
. . . F GMTSL=2:1:$L(GMTSLINE,"|") D Q:$D(GMTSQIT)
. . . . D CKP^GMTSUP Q:$D(GMTSQIT)
. . . . W:$P(GMTSLINE,"|",GMTSL)]"" $P(GMTSLINE,"|",GMTSL),!
D CKP^GMTSUP Q:$D(GMTSQIT) W !
Q
ND ; Writes Diagnosis field
N GMTSD,GMTSDL,GMTSDLI
D CKP^GMTSUP Q:$D(GMTSQIT) W !," Cytopathology Dx:",!
S GMTSD=0
F S GMTSD=$O(^TMP("LRCY",$J,IX,IX0,GMTSD)) Q:GMTSD'>0 D Q:$D(GMTSQIT)
. S GMTSDL=^(GMTSD)
. I $L(GMTSDL)>78 S GMTSDL=$$WRAP^GMTSORC(GMTSDL,78)
. D CKP^GMTSUP Q:$D(GMTSQIT) W $P(GMTSDL,"|"),!
. F GMTSDLI=2:1:$L(GMTSDL,"|") D Q:$D(GMTSQIT)
. . D CKP^GMTSUP Q:$D(GMTSQIT)
. . W:$P(GMTSDL,"|",GMTSDLI)]"" $P(GMTSDL,"|",GMTSDLI),!
Q
OT ; Traverses/Interprets Organ/Tissue Subarray
N OT S OT=0 D CKP^GMTSUP Q:$D(GMTSQIT)
W ?7,"Topography:",?19,^TMP("LRCY",$J,IX,IX0,OT),!
F S OT=$O(^TMP("LRCY",$J,IX,IX0,OT)) Q:OT="" D @$E(OT,1)
Q
D ; Writes Disease Field
D CKP^GMTSUP Q:$D(GMTSQIT)
W:OT="D1"!(GMTSNPG) ?9,"Diseases:"
W ?21,^TMP("LRCY",$J,IX,IX0,OT),!
Q
M ; Writes Morphology Field
N GME
D CKP^GMTSUP Q:$D(GMTSQIT)
W ?7,"Morphology:",?21,$P(^TMP("LRCY",$J,IX,IX0,OT),U),!
D CKP^GMTSUP Q:$D(GMTSQIT)
S GME="" F S GME=$O(^TMP("LRCY",$J,IX,IX0,OT,GME)) Q:GME="" D Q:$D(GMTSQIT)
. D CKP^GMTSUP Q:$D(GMTSQIT)
. W:GME[1!(GMTSNPG) ?9,"Etiology:"
. W ?23,^TMP("LRCY",$J,IX,IX0,OT,GME),!
Q
P ; Writes Procedure Field
N GMTSJ,GMK S GMTSJ=$P(^TMP("LRCY",$J,IX,IX0,OT),U)
D CKP^GMTSUP Q:$D(GMTSQIT)
I $L(GMTSJ)>56 S GMTSJ=$$WRAP^GMTSORC(GMTSJ,56)
D CKP^GMTSUP Q:$D(GMTSQIT) W:((OT="P1")!(GMTSNPG)) ?7,"Procedures:"
W ?21,$P(GMTSJ,"|"),!
F GMK=2:1:$L(GMTSJ,"|") D Q:$D(GMTSQIT)
. D CKP^GMTSUP Q:$D(GMTSQIT)
. W:$P(GMTSJ,"|",GMK)]"" ?23,$P(GMTSJ,"|",GMK),!
K ^UTILITY($J,"W")
Q
XI ; Writes ICD diagnoses
N GMTSDX D CKP^GMTSUP Q:$D(GMTSQIT) W " ICD-9 Diagnoses:" S GMTSDX=0
F S GMTSDX=$O(^TMP("LRCY",$J,IX,IX0,GMTSDX)) Q:GMTSDX="" D Q:$D(GMTSQIT)
. D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG ?2,"ICD-9 Diagnoses:"
. W ?19,$P(^TMP("LRCY",$J,IX,IX0,GMTSDX),U)
. W ?28,$P(^TMP("LRCY",$J,IX,IX0,GMTSDX),U,2),!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSLRCP 5204 printed Dec 13, 2024@01:57:45 Page 2
GMTSLRCP ; SLC/JER,KER - Cytopathology Comp Dvr ; 09/21/2001
+1 ;;2.7;Health Summary;**28,47**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 525 ^LR( all fields
+5 ; DBIA 10035 ^DPT( field 63 Read w/Fileman
+6 ; DBIA 2056 $$GET1^DIQ (file 2)
+7 ;
MAIN ; Cytopathology
+1 NEW GMI,IX,IX0,IX1,MAX,LRDFN
+2 SET LRDFN=+($$GET1^DIQ(2,(+($GET(DFN))_","),63,"I"))
if +LRDFN=0
QUIT
if '$DATA(^LR(LRDFN))
QUIT
+3 SET MAX=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:999)
DO ^GMTSLRPE
+4 if '$DATA(^TMP("LRCY",$JOB))
QUIT
SET IX=""
+5 FOR GMI=1:1:MAX
SET IX=$ORDER(^TMP("LRCY",$JOB,IX))
if IX=""
QUIT
Begin DoDot:1
+6 if GMI>1
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if GMI>1&'GMTSNPG
WRITE !
SET IX0=""
+7 FOR
SET IX0=$ORDER(^TMP("LRCY",$JOB,IX,IX0))
if IX0=""
QUIT
Begin DoDot:2
+8 DO TRVRS
End DoDot:2
if $DATA(GMTSQIT)
QUIT
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+9 KILL ^TMP("LRCY",$JOB)
+10 QUIT
TRVRS ; Traverses/Interprets ^TMP("LRCY",$J,
+1 NEW GMS,SPEC
+2 IF IX0=0
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?8,"Collected:",?19,$PIECE(^TMP("LRCY",$JOB,IX,IX0),U),?31,"Acc:",?36,$PIECE(^TMP("LRCY",$JOB,IX,IX0),U,2),!
QUIT
+3 IF IX0=1
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?9,"Specimen:"
SET GMS=0
FOR
SET GMS=$ORDER(^TMP("LRCY",$JOB,IX,IX0,GMS))
if GMS'>0
QUIT
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?19,^TMP("LRCY",$JOB,IX,IX0,GMS),!
+4 IF IX0=1
IF ($PIECE(^TMP("LRCY",$JOB,IX,IX0),U,2)'>0)
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE ?18,"** REPORT NOT YET RELEASED **",!
+5 if IX0=1
QUIT
DO @$EXTRACT(IX0,1,2)
+6 QUIT
AH ; Writes clinical history
+1 NEW GMTSH,GMTSHL,GMTSHLI
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !,"Brief Clinical Hx:",!
+3 SET GMTSH=0
+4 FOR
SET GMTSH=$ORDER(^TMP("LRCY",$JOB,IX,IX0,GMTSH))
if +GMTSH'>0
QUIT
SET GMTSHL=^(GMTSH)
Begin DoDot:1
+5 IF $LENGTH(GMTSHL)>78
SET GMTSHL=$$WRAP^GMTSORC(GMTSHL,78)
+6 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE $PIECE(GMTSHL,"|"),!
Begin DoDot:2
+7 FOR GMTSHLI=2:1:$LENGTH(GMTSHL,"|")
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if $PIECE(GMTSHL,"|",GMTSHLI)]""
WRITE $PIECE(GMTSHL,"|",GMTSHLI),!
End DoDot:2
End DoDot:1
+8 QUIT
G ; Writes Gross Description
+1 NEW GMTSG,GMTSGL,GMTSGLI
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !,"Gross Description:",!
+3 SET GMTSG=0
+4 FOR
SET GMTSG=$ORDER(^TMP("LRCY",$JOB,IX,IX0,GMTSG))
if GMTSG'>0
QUIT
SET GMTSGL=^(GMTSG)
Begin DoDot:1
+5 IF $LENGTH(GMTSGL)>78
SET GMTSGL=$$WRAP^GMTSORC(GMTSGL,78)
+6 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE $PIECE(GMTSGL,"|"),!
Begin DoDot:2
+7 FOR GMTSGLI=2:1:$LENGTH(GMTSGL,"|")
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if $PIECE(GMTSGL,"|",GMTSGLI)]""
WRITE $PIECE(GMTSGL,"|",GMTSGLI),!
End DoDot:2
End DoDot:1
+8 QUIT
MI ; Writes Microscopic exam/diagnosis field
+1 NEW GMTSM,GMTSML,GMTSMLI
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !,"Microscopic exam:",!
+3 SET GMTSM=0
+4 FOR
SET GMTSM=$ORDER(^TMP("LRCY",$JOB,IX,IX0,GMTSM))
if GMTSM'>0
QUIT
SET GMTSML=^(GMTSM)
Begin DoDot:1
+5 IF $LENGTH(GMTSML)>78
SET GMTSML=$$WRAP^GMTSORC(GMTSML,78)
+6 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE $PIECE(GMTSML,"|"),!
Begin DoDot:2
+7 FOR GMTSMLI=2:1:$LENGTH(GMTSML,"|")
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if $PIECE(GMTSML,"|",GMTSMLI)]""
WRITE $PIECE(GMTSML,"|",GMTSMLI),!
End DoDot:2
End DoDot:1
+8 QUIT
SR ; Writes Supplementary Reports
+1 NEW GMTSLINE,GMTSL,GMTSR,SRDATE,X
SET IX1=0
+2 FOR
SET IX1=$ORDER(^TMP("LRCY",$JOB,IX,IX0,IX1))
if IX1'>0
QUIT
Begin DoDot:1
+3 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
SET SRDATE=^TMP("LRCY",$JOB,IX,IX0,IX1,0)
+4 SET X=SRDATE
DO REGDTM4^GMTSU
WRITE !,"Supplementary Rpt: ",X,!
+5 SET GMTSR=0
+6 FOR
SET GMTSR=$ORDER(^TMP("LRCY",$JOB,IX,IX0,IX1,GMTSR))
if GMTSR'>0
QUIT
Begin DoDot:2
+7 SET GMTSLINE=^TMP("LRCY",$JOB,IX,IX0,IX1,GMTSR)
IF $LENGTH(GMTSLINE)>78
SET GMTSLINE=$$WRAP^GMTSORC(GMTSLINE,78)
+8 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE $PIECE(GMTSLINE,"|"),!
Begin DoDot:3
+9 FOR GMTSL=2:1:$LENGTH(GMTSLINE,"|")
Begin DoDot:4
+10 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+11 if $PIECE(GMTSLINE,"|",GMTSL)]""
WRITE $PIECE(GMTSLINE,"|",GMTSL),!
End DoDot:4
if $DATA(GMTSQIT)
QUIT
End DoDot:3
End DoDot:2
if $DATA(GMTSQIT)
QUIT
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+12 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !
+13 QUIT
ND ; Writes Diagnosis field
+1 NEW GMTSD,GMTSDL,GMTSDLI
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !," Cytopathology Dx:",!
+3 SET GMTSD=0
+4 FOR
SET GMTSD=$ORDER(^TMP("LRCY",$JOB,IX,IX0,GMTSD))
if GMTSD'>0
QUIT
Begin DoDot:1
+5 SET GMTSDL=^(GMTSD)
+6 IF $LENGTH(GMTSDL)>78
SET GMTSDL=$$WRAP^GMTSORC(GMTSDL,78)
+7 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE $PIECE(GMTSDL,"|"),!
+8 FOR GMTSDLI=2:1:$LENGTH(GMTSDL,"|")
Begin DoDot:2
+9 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+10 if $PIECE(GMTSDL,"|",GMTSDLI)]""
WRITE $PIECE(GMTSDL,"|",GMTSDLI),!
End DoDot:2
if $DATA(GMTSQIT)
QUIT
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+11 QUIT
OT ; Traverses/Interprets Organ/Tissue Subarray
+1 NEW OT
SET OT=0
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+2 WRITE ?7,"Topography:",?19,^TMP("LRCY",$JOB,IX,IX0,OT),!
+3 FOR
SET OT=$ORDER(^TMP("LRCY",$JOB,IX,IX0,OT))
if OT=""
QUIT
DO @$EXTRACT(OT,1)
+4 QUIT
D ; Writes Disease Field
+1 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+2 if OT="D1"!(GMTSNPG)
WRITE ?9,"Diseases:"
+3 WRITE ?21,^TMP("LRCY",$JOB,IX,IX0,OT),!
+4 QUIT
M ; Writes Morphology Field
+1 NEW GME
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+3 WRITE ?7,"Morphology:",?21,$PIECE(^TMP("LRCY",$JOB,IX,IX0,OT),U),!
+4 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+5 SET GME=""
FOR
SET GME=$ORDER(^TMP("LRCY",$JOB,IX,IX0,OT,GME))
if GME=""
QUIT
Begin DoDot:1
+6 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+7 if GME[1!(GMTSNPG)
WRITE ?9,"Etiology:"
+8 WRITE ?23,^TMP("LRCY",$JOB,IX,IX0,OT,GME),!
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+9 QUIT
P ; Writes Procedure Field
+1 NEW GMTSJ,GMK
SET GMTSJ=$PIECE(^TMP("LRCY",$JOB,IX,IX0,OT),U)
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+3 IF $LENGTH(GMTSJ)>56
SET GMTSJ=$$WRAP^GMTSORC(GMTSJ,56)
+4 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if ((OT="P1")!(GMTSNPG))
WRITE ?7,"Procedures:"
+5 WRITE ?21,$PIECE(GMTSJ,"|"),!
+6 FOR GMK=2:1:$LENGTH(GMTSJ,"|")
Begin DoDot:1
+7 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+8 if $PIECE(GMTSJ,"|",GMK)]""
WRITE ?23,$PIECE(GMTSJ,"|",GMK),!
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+9 KILL ^UTILITY($JOB,"W")
+10 QUIT
XI ; Writes ICD diagnoses
+1 NEW GMTSDX
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE " ICD-9 Diagnoses:"
SET GMTSDX=0
+2 FOR
SET GMTSDX=$ORDER(^TMP("LRCY",$JOB,IX,IX0,GMTSDX))
if GMTSDX=""
QUIT
Begin DoDot:1
+3 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if GMTSNPG
WRITE ?2,"ICD-9 Diagnoses:"
+4 WRITE ?19,$PIECE(^TMP("LRCY",$JOB,IX,IX0,GMTSDX),U)
+5 WRITE ?28,$PIECE(^TMP("LRCY",$JOB,IX,IX0,GMTSDX),U,2),!
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+6 QUIT
