Routine: LA7SRPT4

LA7SRPT4 ;DALOI/JDB - SCT OVERRIDE REPORT ;03/07/12  09:38

 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229

EN ;

 ; Prompts for #62.48 entry, device, then branches

 N QUE,RTN,R6248,DIC,DTOUT,DUOUT,POP,X,Y,HASSCT,LASEL,ZTSAVE

 S HASSCT=0

 D  Q:'HASSCT  ;

 . ; any SCT Overrides on file?

 . N R6248

 . S R6248=0

 . F  S R6248=$O(^LAHM(62.48,R6248)) Q:'R6248  D  Q:HASSCT  ;

 . . Q:'$D(^LAHM(62.48,R6248,"SCT"))

 . . S HASSCT=1

 . Q:HASSCT

 . W !,"  No SCT Overrides on file."

 S R6248=0

 S DIC=62.48

 S DIC("S")="I $D(^(""SCT""))"

 S X=$$SELECT^LRUTIL(.DIC,.LASEL,"MESSAGE CONFIGURATION",10,0,0,1)

 K DIC

 ; If LASEL=1 then "ALL" was selected

 I X<1 I X'="*" Q

 I $D(DTOUT)!$D(DUOUT) Q

 S RTN="MAIN^LA7SRPT4("_R6248_")"

 I $D(LRSEL)>1 S ZTSAVE("LASEL")=""

 S QUE=$$QUE^LRUTIL(RTN,"SCT OVERRIDE",.ZTSAVE)

 I QUE Q

 D MAIN(R6248)

 D HOME^%ZIS

MAIN(R6248) ;

 ; Setup variables, branch, print footer, perform cleanup.

 ; Expects LASEL array from EN (used with VAUTOMA) to pick

 ; multiple #62.48s (passed in sym tbl for queuing)

 ; Inputs

 ;  R6248 : #62.48 IEN

 N STOP,PGDATA

 S R6248=$G(R6248)

 U IO

 S STOP=0

 S PGDATA("RPTDT")=$$NOW^XLFDT() ;Report Date

 S PGDATA("PGNUM")=1 ;Page Number

 S PGDATA("BM")=0 ;Bottom Margin (lines from bottom)

 S PGDATA("HDR")="D HDR^LA7SRPT4" ;Header exec code

 S PGDATA("FTR")="D FTR^LA7SRPT4" ; Footer exec code

 D HDR^LA7SRPT4

 I R6248 D SCTOVER(R6248,.STOP)

 I 'R6248 D LOOP(.STOP,.LASEL)

 ; Write last footer if needed

 I 'STOP I '$G(PGDATA("WFTR")) D  ;

 . I $G(PGDATA("FTR"))="" Q

 . I $E($G(IOST),1,2)'="C-" D  ;

 . . N I,BM

 . . S BM=$G(PGDATA("BM"))

 . . F I=$Y+1:1:($G(IOSL,60)-BM-1) W !

 . X PGDATA("FTR")

 I $D(ZTQUEUED) S ZTREQ="@"

 I 'STOP I $E(IOST,1,2)="C-" D MORE^LRUTIL()

 D ^%ZISC

LOOP(STOP,SEL) ;

 ; Inputs

 ;  STOP : <byref> see Outputs below

 ;   SEL : <byref> Array of #62.48s to display

 ; Outputs

 ;  STOP : Tracks if user has stopped display

 N R6248,NODE

 ;S R6248=0

 S NODE="^LAHM(62.48,""B"")"

 ;F  S R6248=$O(^LAHM(62.48,"B",R6248)) Q:'R6248  D  Q:STOP  ;

 F  S NODE=$Q(@NODE) Q:NODE=""  Q:$QS(NODE,2)'="B"  D  Q:STOP  ;

 . S R6248=$QS(NODE,4)

 . Q:'$D(^LAHM(62.48,R6248,"SCT"))

 . I $D(SEL)>1 I '$D(SEL(R6248)) Q

 . D SCTOVER(R6248,.STOP)

 . D NP(.STOP) Q:STOP

 . I $O(^LAHM(62.48,R6248)) W ! D NP(.STOP) Q:STOP  W !

 . D NP(.STOP) Q:STOP

SCTOVER(R6248,STOP) ;

 ; Displays SCT override info for a MSG CFG (#62.48)

 ; Inputs

 ;  R6248 : #62.48 IEN

 ;  STOP : <byref> see Outputs below

 ; Outputs

 ;  STOP : Tracks if user has stopped display

 N R62482,R61,R62,D62482,SPECS,SAMPS,TMPNM,SCT,SCT1,SCTOVR,SCTCODES

 N FSIZE,NODE,I,X,REC,NM,DATA,MSIZE,POS

 N DIERR,LAIEN,LAFLDS,POP

 N IOUON,IOUOFF

 S MSIZE(1)=IOM-42 ;max field length (2+2+SCT(18)+2+SCT(18))

 S R6248=$G(R6248)

 S STOP=$G(STOP)

 S TMPNM="LA7SRPT4"

 S X="IOUON;IOUOFF"

 D  ;

 . N %ZIS

 . D ENDR^%ZISS

 D GETFLDS^LA7SRPT1(62.48,R6248_",",".01",.DATA)

 D NP(.STOP) Q:STOP

 W !,"Message Configuration: ",DATA(.01,"E")

 D NP(.STOP) Q:STOP

 I '$D(^LAHM(62.48,R6248,"SCT")) D  Q  ;

 . D NP(.STOP) Q:STOP

 . W !?5,"No SCT Overrides on file."

 . D NP(.STOP) Q:STOP

 D NP(.STOP) Q:STOP

W !

 D NP(.STOP) Q:STOP

 S LAFLDS=".01;.02"

 S R62482=0

 F  S R62482=$O(^LAHM(62.48,R6248,"SCT",R62482)) Q:'R62482  D  ;

 . K D62482

 . S LAIEN=R62482_","_R6248_","

 . D GETFLDS^LA7SRPT1(62.482,LAIEN,LAFLDS,.D62482)

 . Q:'$D(D62482)

 . S (R61,R62)=0

 . S X=D62482(.01,"I")

 . I X["LAB(61," D  ;

 . . S R61=$P(X,";",1)

 . I X["LAB(62," D  ;

 . . S R62=$P(X,";",1)

 . I 'R61 I 'R62 Q

 . S X=$G(D62482(.02,"E"))

 . I R61 S SPECS(R61)=X

 . I R62 S SAMPS(R62)=X

 . ;setup TMP

 . K ^TMP($J,TMPNM)

 . I $D(SPECS) D BLDTMP(61,.SPECS)

 . I $D(SAMPS) D BLDTMP(62,.SAMPS)

 I '$D(^TMP($J,TMPNM)) Q

 ; ^TMP($J,TMPNM,FILE#,.01,REC)=SCT Code

 ; find max length in specimens

 S FSIZE(1)=12 ;spec/sample

 S FSIZE(1)=12+29

 S FSIZE(2)=8 ;SCT code

 S NODE="^TMP($J,TMPNM,61)"

 F  S NODE=$Q(@NODE) Q:NODE=""  Q:$QS(NODE,3)'=61  Q:$QS(NODE,2)'=TMPNM  D  ;

 . S NM=$QS(NODE,4) ;.01 field (sample or topog)

 . S REC=$QS(NODE,5)

 . S X=" ["_REC_"]"

 . S I=$L(NM_X)

 . I I>FSIZE(1) S FSIZE(1)=I

 ; find max length in samples

 S NODE="^TMP($J,TMPNM,62)"

 F  S NODE=$Q(@NODE) Q:NODE=""  Q:$QS(NODE,3)'=62  Q:$QS(NODE,2)'=TMPNM  D  ;

 . S NM=$QS(NODE,4) ;.01 field (sample or topog)

 . S REC=$QS(NODE,5)

 . S X=" ["_REC_"]"

 . S I=$L(NM_X)

 . I I>FSIZE(1) S FSIZE(1)=I

 ; Print Specimens header

 S NODE="^TMP($J,TMPNM,61)"

 I $D(@NODE) D  ;

 . D NP(.STOP) Q:STOP

 . W !?2 D UL(1)

 . W "Specimen [Topography file #61]"

 . S DISP(1)=FSIZE(1)

 . I DISP(1)>MSIZE(1) S DISP(1)=MSIZE(1)

 . W ?2+DISP(1)+2,"VA SCT",?2+DISP(1)+2+18+2,"Non-VA SCT"

 . D UL(0)

 . D NP(.STOP) Q:STOP

 ; Print specimens

 S NODE="^TMP($J,TMPNM,61)"

 F  S NODE=$Q(@NODE) Q:NODE=""  Q:$QS(NODE,3)'=61  Q:$QS(NODE,2)'=TMPNM  D  Q:STOP  ;

 . S NM=$QS(NODE,4)

 . S REC=$QS(NODE,5)

 . S SCT=@NODE

 . I SCT'="" S SCTCODES(" "_SCT)=""

 . S SCTOVR=SPECS(REC)

 . I SCTOVR'="" S SCTCODES(" "_SCTOVR)=""

 . S X=" ["_REC_"]"

 . I $L(NM_X)>MSIZE(1) D  ;

 . . S NM=$E(NM,1,MSIZE(1)-$L(X)-3)_"..."

 . S NM=NM_X

 . S DISP(1)=FSIZE(1)

 . I DISP(1)>MSIZE(1) S DISP(1)=MSIZE(1)

 . D NP(.STOP) Q:STOP

 . W !?2,NM

 . W ?2+DISP(1)+2,SCT,?2+DISP(1)+2+18+2,SCTOVR

 . D NP(.STOP) Q:STOP

 ; Print samples header

 S NODE="^TMP($J,TMPNM,62)"

 I $D(@NODE) D  ;

 . I $D(^TMP($J,TMPNM,61)) D NP(.STOP) Q:STOP  W !

 . D NP(.STOP) Q:STOP

 . W !?2

 . D UL(1)

 . W "Sample [Collection Sample file #62]"

 . S DISP(1)=FSIZE(1)

 . I DISP(1)>MSIZE(1) S DISP(1)=MSIZE(1)

 . W ?2+DISP(1)+2,"VA SCT",?2+DISP(1)+2+18+2,"Non-VA SCT"

 . D UL(0)

 . D NP(.STOP) Q:STOP

 ; Print samples

 F  S NODE=$Q(@NODE) Q:NODE=""  Q:$QS(NODE,3)'=62  Q:$QS(NODE,2)'=TMPNM  D  Q:STOP  ;

 . S NM=$QS(NODE,4)

 . S REC=$QS(NODE,5)

 . S SCT=@NODE

 . I SCT'="" S SCTCODES(" "_SCT)=""

 . S SCTOVR=SAMPS(REC)

 . I SCTOVR'="" S SCTCODES(" "_SCTOVR)=""

 . S X=" ["_REC_"]"

 . I $L(NM_X)>MSIZE(1) D  ;

 . . S NM=$E(NM,1,MSIZE(1)-$L(X)-3)_"..."

 . S NM=NM_X

 . S DISP(1)=FSIZE(1)

 . I DISP(1)>MSIZE(1) S DISP(1)=MSIZE(1)

 . D NP(.STOP) Q:STOP

 . W !?2,NM

 . W ?2+DISP(1)+2,SCT,?2+DISP(1)+2+18+2,SCTOVR

 . D NP(.STOP) Q:STOP

 ; Display SCT code legend

 I 'STOP I $D(SCTCODES) D  ;

 . S SCT=""

 . F  S SCT=$O(SCTCODES(SCT)) Q:SCT=""  D  Q:STOP  ;

 . . S X=$$TRIM^XLFSTR(SCT,"L"," ")

 . . S I=$L(X)

 . . I FSIZE(2)<I S FSIZE(2)=I

. ;

 . D NP(.STOP) Q:STOP

 . W !

 . D NP(.STOP) Q:STOP

 . S POS=0

 . W !?POS

 . D UL(1)

 . W "SCT Code"

 . S POS=POS+FSIZE(2)+2

 . W ?POS,"SCT Preferred Term"

 . D UL(0)

 . S SCT=""

 . F  S SCT=$O(SCTCODES(SCT)) Q:SCT=""  D  Q:STOP  ;

 . . S SCT1=$$TRIM^XLFSTR(SCT,"L"," ")

 . . D NP(.STOP) Q:STOP

 . . S POS=0

 . . W !?POS,SCT1

 . . S X=$$GETPREF^LRSCT(SCT1)

 . . S POS=POS+FSIZE(2)+2

 . . W ?POS

 . . D WRAP^LA7SRPT1(X,POS+1,0,.STOP,.PGDATA)

 . . D NP(.STOP)

 . . Q:STOP

. ;

 K ^TMP($J,TMPNM)

 D UL(0)

HDR ;

 ; Header

 ; Expects PGDATA array

 ; private method

 N STR,RPTDT,PGNUM

 S RPTDT=$G(PGDATA("RPTDT"))

 I RPTDT="" D  ;

 . S RPTDT=$$NOW^XLFDT()

 . S PGDATA("RPTDT")=RPTDT

 S PGNUM=$G(PGDATA("PGNUM"))

 I PGNUM<1 D  ;

 . S PGNUM=1

 . S PGDATA("PGNUM")=PGNUM

 W !,"MESSAGE CONFIGURATION SCT OVERRIDES  "

 S STR="Printed "_$$FMTE^XLFDT(RPTDT,"M")

 S STR=STR_"   Page "_$G(PGNUM,1)

 W ?IOM-$L(STR)-2,STR

 W !,$$REPEAT^XLFSTR("=",IOM)

FTR ;

NP(STOP) ;

 ; Convenience method

 D NP^LRUTIL(.STOP,.PGDATA)

BLDTMP(FILE,IN) ;

 ; Builds ^TMP($J,TMPNM,FILE,.01,IEN)=SCT Code

 ; private method

 ; Inputs

 ;  FILE : File # (61, 62)

 ;    IN :<byref> data array  IN(IEN)=SCT Code

 N REC,DATA,FLDS,TMPNM,F01,F20

 S FILE=$G(FILE)

 S TMPNM="LA7SRPT4"

 S FLDS=".01;20"

 S REC=""

 F  S REC=$O(IN(REC)) Q:'REC  D  ;

 . K DATA

 . D GETFLDS^LA7SRPT1(FILE,REC_",",FLDS,.DATA)

 . Q:'$D(DATA)

 . S F01=DATA(.01,"E")

 . S F20=$G(DATA(20,"E"))

 . S ^TMP($J,TMPNM,FILE,F01,REC)=F20

UL(I) ;

 ; Underline On/Off

 ; private method

 ; Inputs

 ;   I  I=1 turns on underline  I=0 turns off underline

 I $G(IOUON)'="" I $G(IOUOFF)'="" D  ;

 . W:'I IOUOFF

 . W:I IOUON

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7SRPT4   8371     printed  Mar 13, 2025@20:44:22                                                                                                                                                                                                    Page 2

LA7SRPT4  ;DALOI/JDB - SCT OVERRIDE REPORT ;03/07/12  09:38

 +1       ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229

 +2       ;

 +3        QUIT

 +4       ;

EN        ;

 +1       ; Prompts for #62.48 entry, device, then branches

 +2        NEW QUE,RTN,R6248,DIC,DTOUT,DUOUT,POP,X,Y,HASSCT,LASEL,ZTSAVE

 +3        SET HASSCT=0

 +4       ;

           Begin DoDot:1

 +5       ; any SCT Overrides on file?

 +6            NEW R6248

 +7            SET R6248=0

 +8       ;

FOR

                   SET R6248=$ORDER(^LAHM(62.48,R6248))

                   if 'R6248

                       QUIT

                   Begin DoDot:2

 +9                    if '$DATA(^LAHM(62.48,R6248,"SCT"))

                           QUIT

 +10                   SET HASSCT=1

                   End DoDot:2

                   if HASSCT

                       QUIT

 +11           if HASSCT

                   QUIT

 +12           WRITE !,"  No SCT Overrides on file."

           End DoDot:1

           if 'HASSCT

               QUIT

 +13      ;

 +14       SET R6248=0

 +15       SET DIC=62.48

 +16       SET DIC("S")="I $D(^(""SCT""))"

 +17       SET X=$$SELECT^LRUTIL(.DIC,.LASEL,"MESSAGE CONFIGURATION",10,0,0,1)

 +18       KILL DIC

 +19      ; If LASEL=1 then "ALL" was selected

 +20       IF X<1

               IF X'="*"

                   QUIT

 +21       IF $DATA(DTOUT)!$DATA(DUOUT)

               QUIT

 +22       SET RTN="MAIN^LA7SRPT4("_R6248_")"

 +23       IF $DATA(LRSEL)>1

               SET ZTSAVE("LASEL")=""

 +24       SET QUE=$$QUE^LRUTIL(RTN,"SCT OVERRIDE",.ZTSAVE)

 +25       IF QUE

               QUIT

 +26       DO MAIN(R6248)

 +27       DO HOME^%ZIS

 +28       QUIT

 +29      ;

MAIN(R6248) ;

 +1       ; Setup variables, branch, print footer, perform cleanup.

 +2       ; Expects LASEL array from EN (used with VAUTOMA) to pick

 +3       ; multiple #62.48s (passed in sym tbl for queuing)

 +4       ;

 +5       ; Inputs

 +6       ;  R6248 : #62.48 IEN

 +7        NEW STOP,PGDATA

 +8        SET R6248=$GET(R6248)

 +9        USE IO

 +10       SET STOP=0

 +11      ;Report Date

           SET PGDATA("RPTDT")=$$NOW^XLFDT()

 +12      ;Page Number

           SET PGDATA("PGNUM")=1

 +13      ;Bottom Margin (lines from bottom)

           SET PGDATA("BM")=0

 +14      ;Header exec code

           SET PGDATA("HDR")="D HDR^LA7SRPT4"

 +15      ; Footer exec code

           SET PGDATA("FTR")="D FTR^LA7SRPT4"

 +16       DO HDR^LA7SRPT4

 +17       IF R6248

               DO SCTOVER(R6248,.STOP)

 +18       IF 'R6248

               DO LOOP(.STOP,.LASEL)

 +19      ; Write last footer if needed

 +20      ;

           IF 'STOP

               IF '$GET(PGDATA("WFTR"))

                   Begin DoDot:1

 +21                   IF $GET(PGDATA("FTR"))=""

                           QUIT

 +22      ;

                       IF $EXTRACT($GET(IOST),1,2)'="C-"

                           Begin DoDot:2

 +23                           NEW I,BM

 +24                           SET BM=$GET(PGDATA("BM"))

 +25                           FOR I=$Y+1:1:($GET(IOSL,60)-BM-1)

                                   WRITE !

                           End DoDot:2

 +26                   XECUTE PGDATA("FTR")

                   End DoDot:1

 +27       IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +28       IF 'STOP

               IF $EXTRACT(IOST,1,2)="C-"

                   DO MORE^LRUTIL()

 +29       DO ^%ZISC

 +30       QUIT

 +31      ;

LOOP(STOP,SEL) ;

 +1       ; Inputs

 +2       ;  STOP : <byref> see Outputs below

 +3       ;   SEL : <byref> Array of #62.48s to display

 +4       ; Outputs

 +5       ;  STOP : Tracks if user has stopped display

 +6        NEW R6248,NODE

 +7       ;S R6248=0

 +8        SET NODE="^LAHM(62.48,""B"")"

 +9       ;F  S R6248=$O(^LAHM(62.48,"B",R6248)) Q:'R6248  D  Q:STOP  ;

 +10      ;

FOR

               SET NODE=$QUERY(@NODE)

               if NODE=""

                   QUIT

               if $QSUBSCRIPT(NODE,2)'="B"

                   QUIT

               Begin DoDot:1

 +11               SET R6248=$QSUBSCRIPT(NODE,4)

 +12               if '$DATA(^LAHM(62.48,R6248,"SCT"))

                       QUIT

 +13               IF $DATA(SEL)>1

                       IF '$DATA(SEL(R6248))

                           QUIT

 +14               DO SCTOVER(R6248,.STOP)

 +15               DO NP(.STOP)

                   if STOP

                       QUIT

 +16               IF $ORDER(^LAHM(62.48,R6248))

                       WRITE !

                       DO NP(.STOP)

                       if STOP

                           QUIT

                       WRITE !

 +17               DO NP(.STOP)

                   if STOP

                       QUIT

               End DoDot:1

               if STOP

                   QUIT

 +18       QUIT

 +19      ;

SCTOVER(R6248,STOP) ;

 +1       ; Displays SCT override info for a MSG CFG (#62.48)

 +2       ; Inputs

 +3       ;  R6248 : #62.48 IEN

 +4       ;  STOP : <byref> see Outputs below

 +5       ; Outputs

 +6       ;  STOP : Tracks if user has stopped display

 +7        NEW R62482,R61,R62,D62482,SPECS,SAMPS,TMPNM,SCT,SCT1,SCTOVR,SCTCODES

 +8        NEW FSIZE,NODE,I,X,REC,NM,DATA,MSIZE,POS

 +9        NEW DIERR,LAIEN,LAFLDS,POP

 +10       NEW IOUON,IOUOFF

 +11      ;max field length (2+2+SCT(18)+2+SCT(18))

           SET MSIZE(1)=IOM-42

 +12       SET R6248=$GET(R6248)

 +13       SET STOP=$GET(STOP)

 +14       SET TMPNM="LA7SRPT4"

 +15       SET X="IOUON;IOUOFF"

 +16      ;

           Begin DoDot:1

 +17           NEW %ZIS

 +18           DO ENDR^%ZISS

           End DoDot:1

 +19      ;

 +20       DO GETFLDS^LA7SRPT1(62.48,R6248_",",".01",.DATA)

 +21       DO NP(.STOP)

           if STOP

               QUIT

 +22       WRITE !,"Message Configuration: ",DATA(.01,"E")

 +23       DO NP(.STOP)

           if STOP

               QUIT

 +24      ;

           IF '$DATA(^LAHM(62.48,R6248,"SCT"))

               Begin DoDot:1

 +25               DO NP(.STOP)

                   if STOP

                       QUIT

 +26               WRITE !?5,"No SCT Overrides on file."

 +27               DO NP(.STOP)

                   if STOP

                       QUIT

               End DoDot:1

               QUIT

 +28      ;

 +29       DO NP(.STOP)

           if STOP

               QUIT

 +30       WRITE !

 +31       DO NP(.STOP)

           if STOP

               QUIT

 +32       SET LAFLDS=".01;.02"

 +33       SET R62482=0

 +34      ;

FOR

               SET R62482=$ORDER(^LAHM(62.48,R6248,"SCT",R62482))

               if 'R62482

                   QUIT

               Begin DoDot:1

 +35               KILL D62482

 +36               SET LAIEN=R62482_","_R6248_","

 +37               DO GETFLDS^LA7SRPT1(62.482,LAIEN,LAFLDS,.D62482)

 +38               if '$DATA(D62482)

                       QUIT

 +39               SET (R61,R62)=0

 +40               SET X=D62482(.01,"I")

 +41      ;

                   IF X["LAB(61,"

                       Begin DoDot:2

 +42                       SET R61=$PIECE(X,";",1)

                       End DoDot:2

 +43      ;

                   IF X["LAB(62,"

                       Begin DoDot:2

 +44                       SET R62=$PIECE(X,";",1)

                       End DoDot:2

 +45               IF 'R61

                       IF 'R62

                           QUIT

 +46               SET X=$GET(D62482(.02,"E"))

 +47               IF R61

                       SET SPECS(R61)=X

 +48               IF R62

                       SET SAMPS(R62)=X

 +49      ;setup TMP

 +50               KILL ^TMP($JOB,TMPNM)

 +51               IF $DATA(SPECS)

                       DO BLDTMP(61,.SPECS)

 +52               IF $DATA(SAMPS)

                       DO BLDTMP(62,.SAMPS)

               End DoDot:1

 +53       IF '$DATA(^TMP($JOB,TMPNM))

               QUIT

 +54      ;

 +55      ; ^TMP($J,TMPNM,FILE#,.01,REC)=SCT Code

 +56      ; find max length in specimens

 +57      ;spec/sample

           SET FSIZE(1)=12

 +58       SET FSIZE(1)=12+29

 +59      ;SCT code

           SET FSIZE(2)=8

 +60       SET NODE="^TMP($J,TMPNM,61)"

 +61      ;

FOR

               SET NODE=$QUERY(@NODE)

               if NODE=""

                   QUIT

               if $QSUBSCRIPT(NODE,3)'=61

                   QUIT

               if $QSUBSCRIPT(NODE,2)'=TMPNM

                   QUIT

               Begin DoDot:1

 +62      ;.01 field (sample or topog)

                   SET NM=$QSUBSCRIPT(NODE,4)

 +63               SET REC=$QSUBSCRIPT(NODE,5)

 +64               SET X=" ["_REC_"]"

 +65               SET I=$LENGTH(NM_X)

 +66               IF I>FSIZE(1)

                       SET FSIZE(1)=I

               End DoDot:1

 +67      ;

 +68      ; find max length in samples

 +69       SET NODE="^TMP($J,TMPNM,62)"

 +70      ;

FOR

               SET NODE=$QUERY(@NODE)

               if NODE=""

                   QUIT

               if $QSUBSCRIPT(NODE,3)'=62

                   QUIT

               if $QSUBSCRIPT(NODE,2)'=TMPNM

                   QUIT

               Begin DoDot:1

 +71      ;.01 field (sample or topog)

                   SET NM=$QSUBSCRIPT(NODE,4)

 +72               SET REC=$QSUBSCRIPT(NODE,5)

 +73               SET X=" ["_REC_"]"

 +74               SET I=$LENGTH(NM_X)

 +75               IF I>FSIZE(1)

                       SET FSIZE(1)=I

               End DoDot:1

 +76      ;

 +77      ; Print Specimens header

 +78       SET NODE="^TMP($J,TMPNM,61)"

 +79      ;

           IF $DATA(@NODE)

               Begin DoDot:1

 +80               DO NP(.STOP)

                   if STOP

                       QUIT

 +81               WRITE !?2

                   DO UL(1)

 +82               WRITE "Specimen [Topography file #61]"

 +83               SET DISP(1)=FSIZE(1)

 +84               IF DISP(1)>MSIZE(1)

                       SET DISP(1)=MSIZE(1)

 +85               WRITE ?2+DISP(1)+2,"VA SCT",?2+DISP(1)+2+18+2,"Non-VA SCT"

 +86               DO UL(0)

 +87               DO NP(.STOP)

                   if STOP

                       QUIT

               End DoDot:1

 +88      ;

 +89      ; Print specimens

 +90       SET NODE="^TMP($J,TMPNM,61)"

 +91      ;

FOR

               SET NODE=$QUERY(@NODE)

               if NODE=""

                   QUIT

               if $QSUBSCRIPT(NODE,3)'=61

                   QUIT

               if $QSUBSCRIPT(NODE,2)'=TMPNM

                   QUIT

               Begin DoDot:1

 +92               SET NM=$QSUBSCRIPT(NODE,4)

 +93               SET REC=$QSUBSCRIPT(NODE,5)

 +94               SET SCT=@NODE

 +95               IF SCT'=""

                       SET SCTCODES(" "_SCT)=""

 +96               SET SCTOVR=SPECS(REC)

 +97               IF SCTOVR'=""

                       SET SCTCODES(" "_SCTOVR)=""

 +98               SET X=" ["_REC_"]"

 +99      ;

                   IF $LENGTH(NM_X)>MSIZE(1)

                       Begin DoDot:2

 +100                      SET NM=$EXTRACT(NM,1,MSIZE(1)-$LENGTH(X)-3)_"..."

                       End DoDot:2

 +101              SET NM=NM_X

 +102              SET DISP(1)=FSIZE(1)

 +103              IF DISP(1)>MSIZE(1)

                       SET DISP(1)=MSIZE(1)

 +104              DO NP(.STOP)

                   if STOP

                       QUIT

 +105              WRITE !?2,NM

 +106              WRITE ?2+DISP(1)+2,SCT,?2+DISP(1)+2+18+2,SCTOVR

 +107              DO NP(.STOP)

                   if STOP

                       QUIT

               End DoDot:1

               if STOP

                   QUIT

 +108     ;

 +109     ; Print samples header

 +110      SET NODE="^TMP($J,TMPNM,62)"

 +111     ;

           IF $DATA(@NODE)

               Begin DoDot:1

 +112              IF $DATA(^TMP($JOB,TMPNM,61))

                       DO NP(.STOP)

                       if STOP

                           QUIT

                       WRITE !

 +113              DO NP(.STOP)

                   if STOP

                       QUIT

 +114              WRITE !?2

 +115              DO UL(1)

 +116              WRITE "Sample [Collection Sample file #62]"

 +117              SET DISP(1)=FSIZE(1)

 +118              IF DISP(1)>MSIZE(1)

                       SET DISP(1)=MSIZE(1)

 +119              WRITE ?2+DISP(1)+2,"VA SCT",?2+DISP(1)+2+18+2,"Non-VA SCT"

 +120              DO UL(0)

 +121              DO NP(.STOP)

                   if STOP

                       QUIT

               End DoDot:1

 +122     ;

 +123     ; Print samples

 +124     ;

FOR

               SET NODE=$QUERY(@NODE)

               if NODE=""

                   QUIT

               if $QSUBSCRIPT(NODE,3)'=62

                   QUIT

               if $QSUBSCRIPT(NODE,2)'=TMPNM

                   QUIT

               Begin DoDot:1

 +125              SET NM=$QSUBSCRIPT(NODE,4)

 +126              SET REC=$QSUBSCRIPT(NODE,5)

 +127              SET SCT=@NODE

 +128              IF SCT'=""

                       SET SCTCODES(" "_SCT)=""

 +129              SET SCTOVR=SAMPS(REC)

 +130              IF SCTOVR'=""

                       SET SCTCODES(" "_SCTOVR)=""

 +131              SET X=" ["_REC_"]"

 +132     ;

                   IF $LENGTH(NM_X)>MSIZE(1)

                       Begin DoDot:2

 +133                      SET NM=$EXTRACT(NM,1,MSIZE(1)-$LENGTH(X)-3)_"..."

                       End DoDot:2

 +134              SET NM=NM_X

 +135              SET DISP(1)=FSIZE(1)

 +136              IF DISP(1)>MSIZE(1)

                       SET DISP(1)=MSIZE(1)

 +137              DO NP(.STOP)

                   if STOP

                       QUIT

 +138              WRITE !?2,NM

 +139              WRITE ?2+DISP(1)+2,SCT,?2+DISP(1)+2+18+2,SCTOVR

 +140              DO NP(.STOP)

                   if STOP

                       QUIT

               End DoDot:1

               if STOP

                   QUIT

 +141     ;

 +142     ; Display SCT code legend

 +143     ;

           IF 'STOP

               IF $DATA(SCTCODES)

                   Begin DoDot:1

 +144                  SET SCT=""

 +145     ;

FOR

                           SET SCT=$ORDER(SCTCODES(SCT))

                           if SCT=""

                               QUIT

                           Begin DoDot:2

 +146                          SET X=$$TRIM^XLFSTR(SCT,"L"," ")

 +147                          SET I=$LENGTH(X)

 +148                          IF FSIZE(2)<I

                                   SET FSIZE(2)=I

                           End DoDot:2

                           if STOP

                               QUIT

 +149     ;

 +150                  DO NP(.STOP)

                       if STOP

                           QUIT

 +151                  WRITE !

 +152                  DO NP(.STOP)

                       if STOP

                           QUIT

 +153                  SET POS=0

 +154                  WRITE !?POS

 +155                  DO UL(1)

 +156                  WRITE "SCT Code"

 +157                  SET POS=POS+FSIZE(2)+2

 +158                  WRITE ?POS,"SCT Preferred Term"

 +159                  DO UL(0)

 +160                  SET SCT=""

 +161     ;

FOR

                           SET SCT=$ORDER(SCTCODES(SCT))

                           if SCT=""

                               QUIT

                           Begin DoDot:2

 +162                          SET SCT1=$$TRIM^XLFSTR(SCT,"L"," ")

 +163                          DO NP(.STOP)

                               if STOP

                                   QUIT

 +164                          SET POS=0

 +165                          WRITE !?POS,SCT1

 +166                          SET X=$$GETPREF^LRSCT(SCT1)

 +167                          SET POS=POS+FSIZE(2)+2

 +168                          WRITE ?POS

 +169                          DO WRAP^LA7SRPT1(X,POS+1,0,.STOP,.PGDATA)

 +170                          DO NP(.STOP)

 +171                          if STOP

                                   QUIT

                           End DoDot:2

                           if STOP

                               QUIT

 +172     ;

                   End DoDot:1

 +173     ;

 +174      KILL ^TMP($JOB,TMPNM)

 +175      DO UL(0)

 +176      QUIT

 +177     ;

HDR       ;

 +1       ; Header

 +2       ; Expects PGDATA array

 +3       ; private method

 +4        NEW STR,RPTDT,PGNUM

 +5        SET RPTDT=$GET(PGDATA("RPTDT"))

 +6       ;

           IF RPTDT=""

               Begin DoDot:1

 +7                SET RPTDT=$$NOW^XLFDT()

 +8                SET PGDATA("RPTDT")=RPTDT

               End DoDot:1

 +9        SET PGNUM=$GET(PGDATA("PGNUM"))

 +10      ;

           IF PGNUM<1

               Begin DoDot:1

 +11               SET PGNUM=1

 +12               SET PGDATA("PGNUM")=PGNUM

               End DoDot:1

 +13      ;

 +14       WRITE !,"MESSAGE CONFIGURATION SCT OVERRIDES  "

 +15       SET STR="Printed "_$$FMTE^XLFDT(RPTDT,"M")

 +16       SET STR=STR_"   Page "_$GET(PGNUM,1)

 +17       WRITE ?IOM-$LENGTH(STR)-2,STR

 +18       WRITE !,$$REPEAT^XLFSTR("=",IOM)

 +19       QUIT

 +20      ;

FTR       ;

 +1        QUIT

 +2       ;

NP(STOP)  ;

 +1       ; Convenience method

 +2        DO NP^LRUTIL(.STOP,.PGDATA)

 +3        QUIT

 +4       ;

BLDTMP(FILE,IN) ;

 +1       ; Builds ^TMP($J,TMPNM,FILE,.01,IEN)=SCT Code

 +2       ; private method

 +3       ; Inputs

 +4       ;  FILE : File # (61, 62)

 +5       ;    IN :<byref> data array  IN(IEN)=SCT Code

 +6        NEW REC,DATA,FLDS,TMPNM,F01,F20

 +7        SET FILE=$GET(FILE)

 +8        SET TMPNM="LA7SRPT4"

 +9        SET FLDS=".01;20"

 +10       SET REC=""

 +11      ;

FOR

               SET REC=$ORDER(IN(REC))

               if 'REC

                   QUIT

               Begin DoDot:1

 +12               KILL DATA

 +13               DO GETFLDS^LA7SRPT1(FILE,REC_",",FLDS,.DATA)

 +14               if '$DATA(DATA)

                       QUIT

 +15               SET F01=DATA(.01,"E")

 +16               SET F20=$GET(DATA(20,"E"))

 +17               SET ^TMP($JOB,TMPNM,FILE,F01,REC)=F20

               End DoDot:1

 +18       QUIT

 +19      ;

UL(I)     ;

 +1       ; Underline On/Off

 +2       ; private method

 +3       ; Inputs

 +4       ;   I  I=1 turns on underline  I=0 turns off underline

 +5       ;

           IF $GET(IOUON)'=""

               IF $GET(IOUOFF)'=""

                   Begin DoDot:1

 +6                    if 'I

                           WRITE IOUOFF

 +7                    if I

                           WRITE IOUON

                   End DoDot:1

 +8        QUIT

LA7SRPT4.m