LA7SRPT4 ;DALOI/JDB - SCT OVERRIDE REPORT ;03/07/12 09:38
;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
;
Q
;
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
Q
;
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
Q
;
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
Q
;
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)
Q
;
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)
Q
;
FTR ;
Q
;
NP(STOP) ;
; Convenience method
D NP^LRUTIL(.STOP,.PGDATA)
Q
;
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
Q
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7SRPT4 8371 printed Dec 13, 2024@01:39:42 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
