LA7SRPT1 ;DALOI/JDB - SHIPPING MGR REPORTS (CONT) ; 3/13/07 3:00pm
;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
;
Q
;
EN ;
; Displays data for a SHPCFG (#62.9) or a MSG PARAM (#62.48)
; entry. Displays all #62.9s for a #62.48 .
; Prompts for #62.48 or #62.9, Only SCT overrides, then device.
N X,Y,%X,%Y,DIC,DIR,R6248,R629,POP,FLAGS,DTOUT,DUOUT,DIROUT,QUE,RTN
S (R629,R6248)=0
S FLAGS=""
S DIC=62.48
S DIC(0)="AENOQV"
D ^DIC
Q:$D(DTOUT)
Q:$D(DUOUT)
I Y>0 S R6248=+Y
I 'R6248 D ;
. K DIC
. S DIC=62.9
. S DIC(0)="AENOQV"
. D ^DIC
. I Y>0 S R629=+Y
Q:$D(DTOUT)
Q:$D(DUOUT)
I 'R6248 I 'R629 Q
K DIR
S DIR(0)="YO"
S DIR("A")="Only show SCT overrides? "
S DIR("B")="N"
D ^DIR
I Y="^"!(Y="") Q
I Y S $P(FLAGS,"O",2)="" ;insert "O"
I 'Y S FLAGS=$TR(FLAGS,"O","") ;remove "O"
;
S RTN="MAIN^LA7SRPT1("""_R629_""","""_R6248_""","""_FLAGS_""")"
S QUE=$$QUE^LRUTIL(RTN,"SHIPPING CONFIG PRINT")
Q:QUE=-1
Q:QUE>0
D MAIN(R629,R6248,FLAGS)
I $E(IOST,1,2)="C-" D MORE^LRUTIL()
D HOME^%ZIS
Q
;
MAIN(R629,R6248,FLAGS) ;
; Setup variables and branch to proper display method.
; private method
; Inputs
; R629 : <opt> #62.9 IEN (need R629 or R6248)
; R6248 : <opt> #62.48 IEN
; FLAGS : <opt> Flags (O=Only print SCT Overrides)
;
N STOP,PGDATA
S R629=$G(R629)
S R6248=$G(R6248)
S FLAGS=$G(FLAGS)
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^LA7SRPT1" ;Header exec code
S PGDATA("FTR")="D FTR^LA7SRPT1" ; Footer exec code
D HDR^LA7SRPT1
I R629 D SHPCFG(R629,FLAGS,.STOP)
I R6248 D LOOP(R6248,FLAGS,.STOP)
; 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) D ;
. S ZTREQ="@"
D ^%ZISC
Q
;
LOOP(R6248,FLAGS,STOP) ;
; Displays all SHP CFGs (#62.9) for a MSG CFG (#62.48) entry
; private method
; Inputs
; R6248 : #62.48 IEN
; FLAGS : <opt> O=Only show tests with SCT override
; STOP : <byref> See Outputs
; Outputs
; STOP : User wants to stop display -- 1=stop
;
N R629
S R629=0
F S R629=$O(^LAHM(62.9,"AC",R6248,R629)) Q:'R629 D Q:STOP ;
. D SHPCFG(R629,FLAGS,.STOP)
. Q:STOP
. I $O(^LAHM(62.9,"AC",R6248,R629)) W !!
Q
;
SHPCFG(R629,FLAGS,STOP) ;
; Displays SHIPPING CONFIG (#62.9) entry info
; private method
; Inputs
; R629 : #62.9 IEN
; FLAGS : <opt> O=Only show tests with SCT override
; STOP : <byref> See Outputs
; Outputs
; STOP : User wants to stop display -- 1=stop
;
N D629,D629001,D60,D64,R629001,R6248,R62482,R60,R64,X,Z,SCT,SPEC,SMPL
N CNT,WTEST,ISMAPPED,LAIEN,STR
S FLAGS=$G(FLAGS)
S STOP=$G(STOP)
S CNT=0
D GETFLDS(62.9,R629,".01;.07",.D629)
Q:'$D(D629)
S R6248=$G(D629(.07,"I"))
Q:'R6248
D NP Q:STOP
W !,"Shipping Configuration: ",D629(.01,"E")
D NP Q:STOP
I FLAGS["O" I '$D(^LAHM(62.48,R6248,"SCT","B")) D Q ;
. W !?5,"No SCT overrides in ",D629(.07,"E")
;
D NP Q:STOP
S R629001=0
F S R629001=$O(^LAHM(62.9,R629,60,R629001)) Q:'R629001 D Q:STOP ;
. S ISMAPPED=0
. S WTEST=0 ;wrote test's header
. K D629001
. S LAIEN=R629001_","_R629_","
. D GETFLDS(62.9001,LAIEN,".01;.03;.09;",.D629001)
. S LAIEN=R629001_","_R629_","
. D GETFLDS(62.9001,LAIEN,".01;.03;.09;5.3;5.4;5.6;5.7;5.8;5.9;5.1;5.2;5.5",.D629001)
. ;S D629001(.01,"E")=D629001(.01,"E")_"1234 56789 123 23345667533 123.2234 4567543 555 6675433 "
. D NP Q:STOP
. I '$D(D629001) D Q ;
. . W !?8,"No Tests for this configuration."
. S R60=D629001(.01,"I")
. K D60
. D GETFLDS(60,R60,".01;64",.D60)
. S R64=$G(D60(64,"I"))
. K D64
. I R64 D ;
. . D GETFLDS(64,R64,".01;1",.D64)
. I FLAGS'["O" D ;
. . I CNT>0 W !
. . D NP Q:STOP
. . D WTEST S WTEST=1
. ;
. D NP Q:STOP
. S SPEC=$G(D629001(.03,"I"))
. S SMPL=$G(D629001(.09,"I"))
. I SPEC D ;
. . S X=SPEC_";LAB(61,"
. . S R62482=$$ISMAPPED(R6248,X)
. . I FLAGS["O" Q:'R62482
. . I R62482 S ISMAPPED=1
. . I 'WTEST D ;
. . . D NP Q:STOP
. . . I CNT>0 W !
. . . D NP Q:STOP
. . . D WTEST S WTEST=1
. . ;
. . D NP Q:STOP
. . W !?4,"Specimen: " ;,D629001(.03,"E")
. . S STR=D629001(.03,"E")
. . S SCT=$$GETSCT^LRSCT(61,SPEC)
. . I SCT'="" S STR=STR_" ("_SCT_" "_$$GETPREF^LRSCT(SCT)_")"
. . D WRAP(STR,15)
. . S STR=$G(D629001(5.3,"E"),"")_" | "_$G(D629001(5.4,"E"),"")_" | "_$G(D629001(5.6,"E"),"")
. . I $TR(STR,"| ","")'="" W !?6,"HL7 Info: ",STR
. . D NP Q:STOP
. . Q:'R62482
. . D NP Q:STOP
. . S SCT=$$GETMAP(R6248,R62482)
. . S STR=SCT_" "_$$GETPREF^LRSCT(SCT)
. . W !?6,"SCT override: "
. . D WRAP(STR,21)
. . D NP Q:STOP
. ;
. D NP Q:STOP
. ;
. I SMPL D ;
. . S X=SMPL_";LAB(62,"
. . S R62482=$$ISMAPPED(R6248,X)
. . I FLAGS["O" Q:'R62482
. . S ISMAPPED=1
. . I 'WTEST D ;
. . . W:CNT>0 !
. . . D NP Q:STOP
. . . D WTEST S WTEST=1
. . ;
. . W !?4,"Sample: ",D629001(.09,"E")
. . S SCT=$$GETSCT^LRSCT(62,SMPL)
. . I SCT'="" W " (",SCT," ",$$GETPREF^LRSCT(SCT),")"
. . D NP Q:STOP
. . S STR=$G(D629001(5.7,"E"),"")_" | "_$G(D629001(5.8,"E"),"")_" | "_$G(D629001(5.9,"E"),"")
. . I $TR(STR,"| ","")'="" W !?6,"HL7 Info: ",STR
. . D NP Q:STOP
. . Q:'R62482
. . S SCT=$$GETMAP(R6248,R62482)
. . W !?6,"SCT override: "
. . S STR=SCT_" "_$$GETPREF^LRSCT(SCT)
. . D WRAP(STR,21)
. . D NP Q:STOP
. ;
. D NP Q:STOP
. I FLAGS'["O" S CNT=CNT+1
. I FLAGS["O" I ISMAPPED S CNT=CNT+1
Q
;
WTEST ;
; Displays the "top-level" test info
; Expects the D64 and D629001 arrays
; private method
N STR
D NP Q:STOP
W !?2,"Test: ",D629001(.01,"E")
D NP Q:STOP
I $D(D64) W !?2,D64(.01,"E")," (",D64(1,"E"),")"
D NP Q:STOP
;test order code
S STR=$G(D629001(5.1,"E"))_" | "_$G(D629001(5.2,"E"))_" | "_$G(D629001(5.5,"E"))
I $TR(STR," |","")'="" W !,?2,"Order Code: ",STR
D NP Q:STOP
Q
;
GETFLDS(LAFILE,LAIEN,LAFLDS,DATA) ;
; Fields retriever
; Inputs
; LAFILE : File #
; LAIEN : IEN
; LAFLDS : Field #s to retrieve ie ".01;.02;1"
; DATA : <byref> See Outputs
; Outputs
; DATA : Array that holds the internal and external field values
; : ie DATA(.01,"I")=1 DATA(.01,"E")="value"
N DIERR,LAMSG,LAFDA,LATARG
S LAFILE=$G(LAFILE)
S LAIEN=$G(LAIEN)
S:LAIEN'["," LAIEN=LAIEN_","
K DATA
D GETS^DIQ(LAFILE,LAIEN,LAFLDS,"EIN","LATARG","LAMSG")
I $D(LATARG) M DATA=LATARG(LAFILE,LAIEN)
Q
;
ISMAPPED(R6248,VARPTR) ;
; Is this VARPTR (spec or sample) an entry in #62.482?
; Inputs
; R6248 : #62.48 IEN
; VARPTR : Pointer to file #61 or #62 -- ie "123;LAB(61,"
; Output
; 0 or the #62.482 IEN of the VARPTR
Q +$O(^LAHM(62.48,R6248,"SCT","B",VARPTR,0))
;
GETMAP(R6248,R62482) ;
; Returns the SCT code in #62.482
N DIERR,LAMSG,LAIEN
S LAIEN=R62482_","_R6248_","
Q $$GET1^DIQ(62.482,LAIEN,.02,"LAMSG")
;
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 !,"SHIPPING CONFIGURATION DISPLAY "
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 ;
; Footer
; private method
Q
;
NP ;
; New Page handler
; convenience method
D NP^LRUTIL(.STOP,.PGDATA)
Q
;
WRAP(STR,LM,NL,ABORT,PGDATA) ;
; Formats (wraps) and prints a string
; Depending on desired output, caller may need to position
; the cursor at desired column (W ?X) before calling WRAP.
; Inputs
; STR : The string to format
; LM : Left Margin (align to column X)
; NL : New Line? 0=no 1=yes (Write a new line first)
;
N I,J,X,STR2,DIWL,DIWR,DIWF,SPLIT,CHARS,Z
S STR=$G(STR)
S LM=$G(LM,1)
S NL=$G(NL)
S ABORT=$G(ABORT)
K ^UTILITY($J,"W") ;per FM
S CHARS=" .-!+""" ; chars to split on
S X=STR
; display 1st line manually since DIWW doesnt work well here
S STR2=$E(STR,1,IOM-$X)
S X=$E(STR,$L(STR2)+1,$L(STR2)+1) ;next char
I CHARS'[X D ; chars to break on
. S SPLIT=0
. F I=$L(STR2):-1:1 S X=$E(STR2,I,I) I CHARS[X S SPLIT=1 Q
. I SPLIT S STR2=$E(STR2,1,I)
I NL W !
W STR2
S STR2=$E(STR,$L(STR2)+1,$L(STR))
S STR2=$$TRIM^XLFSTR(STR2,"LR"," ")
Q:STR2=""
S X=STR2
S DIWL=LM
S:DIWL<1 DIWL=1
S DIWR=IOM
S DIWF=""
D ^DIWP
; DIWW forces an extra linefeed at end so printout manually
S I=$O(^UTILITY($J,"W",0))
S J=0
F S J=$O(^UTILITY($J,"W",I,J)) Q:'J D Q:ABORT ;
. S X=^UTILITY($J,"W",I,J,0)
. S X=$$TRIM^XLFSTR(X,"RL"," ")
. D NP^LRUTIL(.ABORT,.PGDATA) Q:ABORT
. W !,?LM-1,X
K ^UTILITY($J,"W")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7SRPT1 9031 printed Nov 22, 2024@16:49:51 Page 2
LA7SRPT1 ;DALOI/JDB - SHIPPING MGR REPORTS (CONT) ; 3/13/07 3:00pm
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
+2 ;
+3 QUIT
+4 ;
EN ;
+1 ; Displays data for a SHPCFG (#62.9) or a MSG PARAM (#62.48)
+2 ; entry. Displays all #62.9s for a #62.48 .
+3 ; Prompts for #62.48 or #62.9, Only SCT overrides, then device.
+4 NEW X,Y,%X,%Y,DIC,DIR,R6248,R629,POP,FLAGS,DTOUT,DUOUT,DIROUT,QUE,RTN
+5 SET (R629,R6248)=0
+6 SET FLAGS=""
+7 SET DIC=62.48
+8 SET DIC(0)="AENOQV"
+9 DO ^DIC
+10 if $DATA(DTOUT)
QUIT
+11 if $DATA(DUOUT)
QUIT
+12 IF Y>0
SET R6248=+Y
+13 ;
IF 'R6248
Begin DoDot:1
+14 KILL DIC
+15 SET DIC=62.9
+16 SET DIC(0)="AENOQV"
+17 DO ^DIC
+18 IF Y>0
SET R629=+Y
End DoDot:1
+19 if $DATA(DTOUT)
QUIT
+20 if $DATA(DUOUT)
QUIT
+21 IF 'R6248
IF 'R629
QUIT
+22 KILL DIR
+23 SET DIR(0)="YO"
+24 SET DIR("A")="Only show SCT overrides? "
+25 SET DIR("B")="N"
+26 DO ^DIR
+27 IF Y="^"!(Y="")
QUIT
+28 ;insert "O"
IF Y
SET $PIECE(FLAGS,"O",2)=""
+29 ;remove "O"
IF 'Y
SET FLAGS=$TRANSLATE(FLAGS,"O","")
+30 ;
+31 SET RTN="MAIN^LA7SRPT1("""_R629_""","""_R6248_""","""_FLAGS_""")"
+32 SET QUE=$$QUE^LRUTIL(RTN,"SHIPPING CONFIG PRINT")
+33 if QUE=-1
QUIT
+34 if QUE>0
QUIT
+35 DO MAIN(R629,R6248,FLAGS)
+36 IF $EXTRACT(IOST,1,2)="C-"
DO MORE^LRUTIL()
+37 DO HOME^%ZIS
+38 QUIT
+39 ;
MAIN(R629,R6248,FLAGS) ;
+1 ; Setup variables and branch to proper display method.
+2 ; private method
+3 ; Inputs
+4 ; R629 : <opt> #62.9 IEN (need R629 or R6248)
+5 ; R6248 : <opt> #62.48 IEN
+6 ; FLAGS : <opt> Flags (O=Only print SCT Overrides)
+7 ;
+8 NEW STOP,PGDATA
+9 SET R629=$GET(R629)
+10 SET R6248=$GET(R6248)
+11 SET FLAGS=$GET(FLAGS)
+12 USE IO
+13 SET STOP=0
+14 ;Report Date
SET PGDATA("RPTDT")=$$NOW^XLFDT()
+15 ;Page Number
SET PGDATA("PGNUM")=1
+16 ;Bottom Margin (lines from bottom)
SET PGDATA("BM")=0
+17 ;Header exec code
SET PGDATA("HDR")="D HDR^LA7SRPT1"
+18 ; Footer exec code
SET PGDATA("FTR")="D FTR^LA7SRPT1"
+19 DO HDR^LA7SRPT1
+20 IF R629
DO SHPCFG(R629,FLAGS,.STOP)
+21 IF R6248
DO LOOP(R6248,FLAGS,.STOP)
+22 ; Write last footer if needed
+23 ;
IF 'STOP
IF '$GET(PGDATA("WFTR"))
Begin DoDot:1
+24 IF $GET(PGDATA("FTR"))=""
QUIT
+25 ;
IF $EXTRACT($GET(IOST),1,2)'="C-"
Begin DoDot:2
+26 NEW I,BM
+27 SET BM=$GET(PGDATA("BM"))
+28 FOR I=$Y+1:1:($GET(IOSL,60)-BM-1)
WRITE !
End DoDot:2
+29 XECUTE PGDATA("FTR")
End DoDot:1
+30 ;
+31 ;
IF $DATA(ZTQUEUED)
Begin DoDot:1
+32 SET ZTREQ="@"
End DoDot:1
+33 DO ^%ZISC
+34 QUIT
+35 ;
LOOP(R6248,FLAGS,STOP) ;
+1 ; Displays all SHP CFGs (#62.9) for a MSG CFG (#62.48) entry
+2 ; private method
+3 ; Inputs
+4 ; R6248 : #62.48 IEN
+5 ; FLAGS : <opt> O=Only show tests with SCT override
+6 ; STOP : <byref> See Outputs
+7 ; Outputs
+8 ; STOP : User wants to stop display -- 1=stop
+9 ;
+10 NEW R629
+11 SET R629=0
+12 ;
FOR
SET R629=$ORDER(^LAHM(62.9,"AC",R6248,R629))
if 'R629
QUIT
Begin DoDot:1
+13 DO SHPCFG(R629,FLAGS,.STOP)
+14 if STOP
QUIT
+15 IF $ORDER(^LAHM(62.9,"AC",R6248,R629))
WRITE !!
End DoDot:1
if STOP
QUIT
+16 QUIT
+17 ;
SHPCFG(R629,FLAGS,STOP) ;
+1 ; Displays SHIPPING CONFIG (#62.9) entry info
+2 ; private method
+3 ; Inputs
+4 ; R629 : #62.9 IEN
+5 ; FLAGS : <opt> O=Only show tests with SCT override
+6 ; STOP : <byref> See Outputs
+7 ; Outputs
+8 ; STOP : User wants to stop display -- 1=stop
+9 ;
+10 NEW D629,D629001,D60,D64,R629001,R6248,R62482,R60,R64,X,Z,SCT,SPEC,SMPL
+11 NEW CNT,WTEST,ISMAPPED,LAIEN,STR
+12 SET FLAGS=$GET(FLAGS)
+13 SET STOP=$GET(STOP)
+14 SET CNT=0
+15 DO GETFLDS(62.9,R629,".01;.07",.D629)
+16 if '$DATA(D629)
QUIT
+17 SET R6248=$GET(D629(.07,"I"))
+18 if 'R6248
QUIT
+19 DO NP
if STOP
QUIT
+20 WRITE !,"Shipping Configuration: ",D629(.01,"E")
+21 DO NP
if STOP
QUIT
+22 ;
IF FLAGS["O"
IF '$DATA(^LAHM(62.48,R6248,"SCT","B"))
Begin DoDot:1
+23 WRITE !?5,"No SCT overrides in ",D629(.07,"E")
End DoDot:1
QUIT
+24 ;
+25 DO NP
if STOP
QUIT
+26 SET R629001=0
+27 ;
FOR
SET R629001=$ORDER(^LAHM(62.9,R629,60,R629001))
if 'R629001
QUIT
Begin DoDot:1
+28 SET ISMAPPED=0
+29 ;wrote test's header
SET WTEST=0
+30 KILL D629001
+31 SET LAIEN=R629001_","_R629_","
+32 DO GETFLDS(62.9001,LAIEN,".01;.03;.09;",.D629001)
+33 SET LAIEN=R629001_","_R629_","
+34 DO GETFLDS(62.9001,LAIEN,".01;.03;.09;5.3;5.4;5.6;5.7;5.8;5.9;5.1;5.2;5.5",.D629001)
+35 ;S D629001(.01,"E")=D629001(.01,"E")_"1234 56789 123 23345667533 123.2234 4567543 555 6675433 "
+36 DO NP
if STOP
QUIT
+37 ;
IF '$DATA(D629001)
Begin DoDot:2
+38 WRITE !?8,"No Tests for this configuration."
End DoDot:2
QUIT
+39 SET R60=D629001(.01,"I")
+40 KILL D60
+41 DO GETFLDS(60,R60,".01;64",.D60)
+42 SET R64=$GET(D60(64,"I"))
+43 KILL D64
+44 ;
IF R64
Begin DoDot:2
+45 DO GETFLDS(64,R64,".01;1",.D64)
End DoDot:2
+46 ;
IF FLAGS'["O"
Begin DoDot:2
+47 IF CNT>0
WRITE !
+48 DO NP
if STOP
QUIT
+49 DO WTEST
SET WTEST=1
End DoDot:2
+50 ;
+51 DO NP
if STOP
QUIT
+52 SET SPEC=$GET(D629001(.03,"I"))
+53 SET SMPL=$GET(D629001(.09,"I"))
+54 ;
IF SPEC
Begin DoDot:2
+55 SET X=SPEC_";LAB(61,"
+56 SET R62482=$$ISMAPPED(R6248,X)
+57 IF FLAGS["O"
if 'R62482
QUIT
+58 IF R62482
SET ISMAPPED=1
+59 ;
IF 'WTEST
Begin DoDot:3
+60 DO NP
if STOP
QUIT
+61 IF CNT>0
WRITE !
+62 DO NP
if STOP
QUIT
+63 DO WTEST
SET WTEST=1
End DoDot:3
+64 ;
+65 DO NP
if STOP
QUIT
+66 ;,D629001(.03,"E")
WRITE !?4,"Specimen: "
+67 SET STR=D629001(.03,"E")
+68 SET SCT=$$GETSCT^LRSCT(61,SPEC)
+69 IF SCT'=""
SET STR=STR_" ("_SCT_" "_$$GETPREF^LRSCT(SCT)_")"
+70 DO WRAP(STR,15)
+71 SET STR=$GET(D629001(5.3,"E"),"")_" | "_$GET(D629001(5.4,"E"),"")_" | "_$GET(D629001(5.6,"E"),"")
+72 IF $TRANSLATE(STR,"| ","")'=""
WRITE !?6,"HL7 Info: ",STR
+73 DO NP
if STOP
QUIT
+74 if 'R62482
QUIT
+75 DO NP
if STOP
QUIT
+76 SET SCT=$$GETMAP(R6248,R62482)
+77 SET STR=SCT_" "_$$GETPREF^LRSCT(SCT)
+78 WRITE !?6,"SCT override: "
+79 DO WRAP(STR,21)
+80 DO NP
if STOP
QUIT
End DoDot:2
+81 ;
+82 DO NP
if STOP
QUIT
+83 ;
+84 ;
IF SMPL
Begin DoDot:2
+85 SET X=SMPL_";LAB(62,"
+86 SET R62482=$$ISMAPPED(R6248,X)
+87 IF FLAGS["O"
if 'R62482
QUIT
+88 SET ISMAPPED=1
+89 ;
IF 'WTEST
Begin DoDot:3
+90 if CNT>0
WRITE !
+91 DO NP
if STOP
QUIT
+92 DO WTEST
SET WTEST=1
End DoDot:3
+93 ;
+94 WRITE !?4,"Sample: ",D629001(.09,"E")
+95 SET SCT=$$GETSCT^LRSCT(62,SMPL)
+96 IF SCT'=""
WRITE " (",SCT," ",$$GETPREF^LRSCT(SCT),")"
+97 DO NP
if STOP
QUIT
+98 SET STR=$GET(D629001(5.7,"E"),"")_" | "_$GET(D629001(5.8,"E"),"")_" | "_$GET(D629001(5.9,"E"),"")
+99 IF $TRANSLATE(STR,"| ","")'=""
WRITE !?6,"HL7 Info: ",STR
+100 DO NP
if STOP
QUIT
+101 if 'R62482
QUIT
+102 SET SCT=$$GETMAP(R6248,R62482)
+103 WRITE !?6,"SCT override: "
+104 SET STR=SCT_" "_$$GETPREF^LRSCT(SCT)
+105 DO WRAP(STR,21)
+106 DO NP
if STOP
QUIT
End DoDot:2
+107 ;
+108 DO NP
if STOP
QUIT
+109 IF FLAGS'["O"
SET CNT=CNT+1
+110 IF FLAGS["O"
IF ISMAPPED
SET CNT=CNT+1
End DoDot:1
if STOP
QUIT
+111 QUIT
+112 ;
WTEST ;
+1 ; Displays the "top-level" test info
+2 ; Expects the D64 and D629001 arrays
+3 ; private method
+4 NEW STR
+5 DO NP
if STOP
QUIT
+6 WRITE !?2,"Test: ",D629001(.01,"E")
+7 DO NP
if STOP
QUIT
+8 IF $DATA(D64)
WRITE !?2,D64(.01,"E")," (",D64(1,"E"),")"
+9 DO NP
if STOP
QUIT
+10 ;test order code
+11 SET STR=$GET(D629001(5.1,"E"))_" | "_$GET(D629001(5.2,"E"))_" | "_$GET(D629001(5.5,"E"))
+12 IF $TRANSLATE(STR," |","")'=""
WRITE !,?2,"Order Code: ",STR
+13 DO NP
if STOP
QUIT
+14 QUIT
+15 ;
GETFLDS(LAFILE,LAIEN,LAFLDS,DATA) ;
+1 ; Fields retriever
+2 ; Inputs
+3 ; LAFILE : File #
+4 ; LAIEN : IEN
+5 ; LAFLDS : Field #s to retrieve ie ".01;.02;1"
+6 ; DATA : <byref> See Outputs
+7 ; Outputs
+8 ; DATA : Array that holds the internal and external field values
+9 ; : ie DATA(.01,"I")=1 DATA(.01,"E")="value"
+10 NEW DIERR,LAMSG,LAFDA,LATARG
+11 SET LAFILE=$GET(LAFILE)
+12 SET LAIEN=$GET(LAIEN)
+13 if LAIEN'[","
SET LAIEN=LAIEN_","
+14 KILL DATA
+15 DO GETS^DIQ(LAFILE,LAIEN,LAFLDS,"EIN","LATARG","LAMSG")
+16 IF $DATA(LATARG)
MERGE DATA=LATARG(LAFILE,LAIEN)
+17 QUIT
+18 ;
ISMAPPED(R6248,VARPTR) ;
+1 ; Is this VARPTR (spec or sample) an entry in #62.482?
+2 ; Inputs
+3 ; R6248 : #62.48 IEN
+4 ; VARPTR : Pointer to file #61 or #62 -- ie "123;LAB(61,"
+5 ; Output
+6 ; 0 or the #62.482 IEN of the VARPTR
+7 QUIT +$ORDER(^LAHM(62.48,R6248,"SCT","B",VARPTR,0))
+8 ;
GETMAP(R6248,R62482) ;
+1 ; Returns the SCT code in #62.482
+2 NEW DIERR,LAMSG,LAIEN
+3 SET LAIEN=R62482_","_R6248_","
+4 QUIT $$GET1^DIQ(62.482,LAIEN,.02,"LAMSG")
+5 ;
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 !,"SHIPPING CONFIGURATION DISPLAY "
+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 ; Footer
+2 ; private method
+3 QUIT
+4 ;
NP ;
+1 ; New Page handler
+2 ; convenience method
+3 DO NP^LRUTIL(.STOP,.PGDATA)
+4 QUIT
+5 ;
WRAP(STR,LM,NL,ABORT,PGDATA) ;
+1 ; Formats (wraps) and prints a string
+2 ; Depending on desired output, caller may need to position
+3 ; the cursor at desired column (W ?X) before calling WRAP.
+4 ; Inputs
+5 ; STR : The string to format
+6 ; LM : Left Margin (align to column X)
+7 ; NL : New Line? 0=no 1=yes (Write a new line first)
+8 ;
+9 NEW I,J,X,STR2,DIWL,DIWR,DIWF,SPLIT,CHARS,Z
+10 SET STR=$GET(STR)
+11 SET LM=$GET(LM,1)
+12 SET NL=$GET(NL)
+13 SET ABORT=$GET(ABORT)
+14 ;per FM
KILL ^UTILITY($JOB,"W")
+15 ; chars to split on
SET CHARS=" .-!+"""
+16 SET X=STR
+17 ; display 1st line manually since DIWW doesnt work well here
+18 SET STR2=$EXTRACT(STR,1,IOM-$X)
+19 ;next char
SET X=$EXTRACT(STR,$LENGTH(STR2)+1,$LENGTH(STR2)+1)
+20 ; chars to break on
IF CHARS'[X
Begin DoDot:1
+21 SET SPLIT=0
+22 FOR I=$LENGTH(STR2):-1:1
SET X=$EXTRACT(STR2,I,I)
IF CHARS[X
SET SPLIT=1
QUIT
+23 IF SPLIT
SET STR2=$EXTRACT(STR2,1,I)
End DoDot:1
+24 IF NL
WRITE !
+25 WRITE STR2
+26 SET STR2=$EXTRACT(STR,$LENGTH(STR2)+1,$LENGTH(STR))
+27 SET STR2=$$TRIM^XLFSTR(STR2,"LR"," ")
+28 if STR2=""
QUIT
+29 SET X=STR2
+30 SET DIWL=LM
+31 if DIWL<1
SET DIWL=1
+32 SET DIWR=IOM
+33 SET DIWF=""
+34 DO ^DIWP
+35 ; DIWW forces an extra linefeed at end so printout manually
+36 SET I=$ORDER(^UTILITY($JOB,"W",0))
+37 SET J=0
+38 ;
FOR
SET J=$ORDER(^UTILITY($JOB,"W",I,J))
if 'J
QUIT
Begin DoDot:1
+39 SET X=^UTILITY($JOB,"W",I,J,0)
+40 SET X=$$TRIM^XLFSTR(X,"RL"," ")
+41 DO NP^LRUTIL(.ABORT,.PGDATA)
if ABORT
QUIT
+42 WRITE !,?LM-1,X
End DoDot:1
if ABORT
QUIT
+43 KILL ^UTILITY($JOB,"W")
+44 QUIT
