GMTSLRA.m

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 ---GMTSLRA   3652     printed  Mar 13, 2025@21:02:17                                                                                                                                                                                                     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