LA7SRPT2 ;DALOI/JDB - CODE USAGE REPORT ;03/07/12 09:04
;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
;
Q
;
ASK ;
; Prompts for Identifier and Coding System then performs search
N SYS,ID,DIR,DTOUT,DUOUT,DIRUT,DIROUT,QUE,POP,%ZIS,QUE,X,Y,RTN
S DIR(0)="FAO"
S DIR("A")="Enter IDENTIFIER: "
S DIR("?")="Enter an identifier (ie 123-4)"
D ^DIR
I $E(Y)="^" Q
I $TR(Y," ","")="" Q
S ID=Y
K DIR
S DIR(0)="FAO"
S DIR("A")="Enter CODING SYSTEM: "
S DIR("?")="Enter a coding system (ie LN)"
D ^DIR
I $E(Y)="^" Q
I $TR(Y," ","")="" Q
S SYS=Y
S RTN="MAIN^LA7VLCM8("""_ID_""","""_SYS_""")"
S QUE=$$QUE^LRUTIL(RTN,"PRINT CODE USAGE")
I QUE Q
;
D MAIN(ID,SYS,"","")
I $E(IOST,1,2)="C-" D MORE^LRUTIL()
D HOME^%ZIS
Q
;
MAIN(CODE,SYS,MSGCFG,SHPCFG) ;
N STOP
S CODE=$G(CODE)
S SYS=$G(SYS)
S MSGCFG=$G(MSGCFG)
S SHPCFG=$G(SHPCFG)
U IO
S STOP=0
D FIND(CODE,SYS,MSGCFG,SHPCFG,.STOP)
I $D(ZTQUEUED) D ;
. S ZTREQ="@"
D ^%ZISC
Q
;
FIND(CODE,SYS,MSGCFG,SHPCFG,STOP) ;
; Searches and displays search results for the code/code system
; in files #61,61.2,62,62.06,62.47,62.48,62.9
; Inputs
; CODE : Code (or Identifier)
; SYS : Coding System (ie "SCT")
; MSGCFG : <opt> Message Config (#62.48)
; SHPCFG : <opt> Shipping Config (#62.9)
; STOP : <byref> See Outputs
;
; Outputs
; STOP : Has user selected to stop the display
;
N STATUS,FOUND,DATA,X,Y,DIERR
N R61,R612,R62,R6206,R6247,R624701,R6248,R624802,R629,R629001
S CODE=$G(CODE)
S SYS=$G(SYS)
S MSGCFG=$G(MSGCFG)
S SHPCFG=$G(SHPCFG)
S STOP=0
S STATUS=0
I SYS="SCT" D ;
. S X=$$CODE^LRSCT(CODE,"SCT",,"DATA")
. I X<1 W !,"Invalid SCT code"
. I X>0 W !,"SCT FSN: ",DATA("F")
;
I SYS="LN" D ;
. S X=$$LOINCFSN^LA7VLCM1(CODE)
. I X="" W !,"Invalid LOINC code"
. I X'="" W !,"LOINC FSN: ",X
;
D NP(.STOP)
Q:STOP
W !!,"Checking TOPOGRAPHY file (#61)"
K FOUND
S X=$$F61^LA7SRPT3(CODE,SYS,.FOUND)
I 'X D ;
. W !,?5,"No matches"
I X D ;
. S STATUS=1
. S R61=0
. F S R61=$O(FOUND(1,R61)) Q:'R61 D Q:STOP ;
. . S DATA=$G(^LAB(61,R61,0))
. . S X=$P(DATA,U,1)
. . W !,?2,"#",R61,": ",X
. . D NP(.STOP)
Q:STOP
D NP(.STOP)
Q:STOP
;
W !!,"Checking ETIOLOGY FIELD (#61.2) file"
K FOUND
S X=$$F612^LA7SRPT3(CODE,SYS,.FOUND)
I 'X D ;
. W !,?5,"No matches"
I X D ;
. S STATUS=1
. S R612=0
. F S R612=$O(FOUND(1,R612)) Q:'R612 D Q:STOP ;
. . S DATA=$G(^LAB(61.2,R612,0))
. . S X=$P(DATA,U,1)
. . W !,?2,"#",R612,": ",X
. . D NP(.STOP)
. ;
Q:STOP
D NP(.STOP)
Q:STOP
;
W !!,"Checking COLLECTION SAMPLE (#62) file"
K FOUND
S X=$$F62^LA7SRPT3(CODE,SYS,.FOUND)
I 'X D ;
. W !,?5,"No matches"
I X D ;
. S STATUS=1
. S R62=0
. F S R62=$O(FOUND(1,R62)) Q:'R62 D Q:STOP ;
. . S DATA=$G(^LAB(62,R62,0))
. . S X=$P(DATA,U,1)
. . W !,?2,"#",R62,": ",X
. . D NP(.STOP)
. ;
Q:STOP
D NP(.STOP)
Q:STOP
;
W !!,"Checking ANTIMICROBIAL SUSCEPTIBILITY (#62.06) file"
K FOUND
S X=$$F6206^LA7SRPT3(CODE,SYS,.FOUND)
I 'X D ;
. W !,?5,"No matches"
I X D ;
. S STATUS=1
. S R6206=0
. F S R6206=$O(FOUND(1,R6206)) Q:'R6206 D Q:STOP ;
. . S DATA=$G(^LAB(62.06,R6206,0))
. . S X=$P(DATA,U,1)
. . W !,?2,"#",R6206,": ",X
. . D NP(.STOP)
. ;
Q:STOP
D NP(.STOP)
Q:STOP
;
W !!,"Checking LAB CODE MAPPING (#62.47) file"
K FOUND
S X=$$F6247^LA7SRPT3(CODE,SYS,.FOUND,MSGCFG)
I 'X D ;
. W !,?5,"No matches"
I X D ;
. N CONCEPT,LAMSG,LATARG,DIERR
. N F01,F22
. S CONCEPT=""
. S STATUS=1
. S R6247=0
. F S R6247=$O(FOUND(1,R6247)) Q:'R6247 D Q:STOP ;
. . S R624701=0
. . F S R624701=$O(FOUND(1,R6247,R624701)) Q:'R624701 D Q:STOP ;
. . . S DATA=$G(^LAB(62.47,R6247,0))
. . . S X=$P(DATA,U,1)
. . . I CONCEPT'=X W:$O(FOUND(1,0))'=R6247 ! W !,?2,X," (#62.47:",R6247,")" S CONCEPT=X
. . . D NP(.STOP)
. . . Q:STOP
. . . S DATA=$G(^LAB(62.47,R6247,1,R624701,0))
. . . S F01=$P(DATA,U,1)
. . . K LATARG,DIERR,LAMSG
. . . D GETS^DIQ(62.4701,R624701_","_R6247_",",2.2,"EI","LATARG","LAMSG")
. . . S R6248=$G(LATARG(62.4701,R624701_","_R6247_",",2.2,"I"))
. . . S F22=$G(LATARG(62.4701,R624701_","_R6247_",",2.2,"E"))
. . . I F22="" S F22="No Message Config"
. . . W !,?4,"#",R624701,": ",F01," (",F22,")"
. . . D NP(.STOP)
. . . Q:STOP
. . . D ;
. . . . I SYS'="SCT" D ;
. . . . . S X=$$HL2LAH^LA7VHLU6(CODE,"",SYS,1,R6248)
. . . . . I X'="" W !,?6,"$$HL2LAH:",X
. . . . I SYS'="LN" D ;
. . . . . S Y=$$HL2VA^LA7VHLU6(CODE,"",SYS,1,R6247,R6248)
. . . . . I Y'="" W:X="" !,?6 W:X'="" " " W "$$HL2VA:",Y
. . . D NP(.STOP)
. . . Q:STOP
. . . I $O(FOUND(1,R6247,R624701)) W !
. . . ;
. . ;
. ;
Q:STOP
D NP(.STOP)
Q:STOP
;
W !!,"Checking LA7 MESSAGE PARAMETER (#62.48) file"
K FOUND
S X=$$F6248^LA7SRPT3(CODE,SYS,.FOUND,MSGCFG)
I 'X D ;
. W !,?5,"No matches"
I X D ;
. N CONFIG,VAENTRY,NL
. S CONFIG=""
. S STATUS=1
. S R6248=0
. F S R6248=$O(FOUND(1,R6248)) Q:'R6248 D Q:STOP ;
. . S DATA=$G(^LAHM(62.48,R6248,0))
. . S X=$P(DATA,U,1)
. . I CONFIG'=X W !,?2,X," (#62.48:",R6248,")" S CONFIG=X W !,?2,"NON-VA ORDER SNOMED CODES sub-file"
. . D NP(.STOP)
. . Q:STOP
. . S R624802=0
. . F S R624802=$O(FOUND(1,R6248,R624802)) Q:'R624802 D Q:STOP ;
. . . S DATA=$G(^LAHM(62.48,R6248,"SCT",R624802,0))
. . . S VAENTRY=$P(DATA,U,1)
. . . S X=$P(VAENTRY,";",2)_":"_$P(VAENTRY,";",1)
. . . S X=$P(X,"(",2)
. . . S X=$TR(X,",","")
. . . S NL=0
. . . W !,?4,"#",R624802,": ",$$VARPTR01^LA7XREF(VAENTRY)," (#",X,")"
. . . D NP(.STOP)
. . . Q:STOP
. . . I $D(FOUND(2,R6248,R624802)) D ;
. . . . W !,?6," .01 is mapped" S NL=1
. . . ;
. . . I $D(FOUND(3,R6248,R624802)) D ;
. . . . W:'NL !,?6 W:NL ", " W "Used as override"
. . . I $O(FOUND(1,R6248,R624802)) W !
. . . D NP(.STOP)
. . ;
. ;
Q:STOP
D NP(.STOP)
Q:STOP
;
W !!,"Checking LAB SHIPPING CONFIGURATION (#62.9) file"
K FOUND
S X=$$F629^LA7SRPT3(CODE,SYS,.FOUND,SHPCFG)
I 'X D ;
. W !,?5,"No matches"
I X D ;
. N CONFIG,TEST,F03,F09,F53,F57,DIERR,LAMSG,COMMA
. S (CONFIG,TEST)=""
. S (F03,F09,F53,F57)=0
. S STATUS=1
. S R629=0
. F S R629=$O(FOUND(1,R629)) Q:'R629 D Q:STOP ;
. . S DATA=$G(^LAHM(62.9,R629,0))
. . S X=$P(DATA,U,1)
. . I CONFIG'=X W !,?2,X," (#62.9:",R629,")" S CONFIG=X
. . D NP(.STOP)
. . Q:STOP
. . S R629001=0
. . S TEST=""
. . F S R629001=$O(FOUND(1,R629,R629001)) Q:'R629001 D Q:STOP ;
. . . S DATA=$G(^LAHM(62.9,R629,60,R629001,0))
. . . S X=$P(DATA,U,1)
. . . K LAMSG,DIERR
. . . S X=$$GET1^DIQ(60,X_",",.01,"E","","LAMSG")
. . . I TEST'=X W !,?4,"Test Profile" W !,?4,"#",R629001,": ",X S TEST=X
. . . D NP(.STOP)
. . . Q:STOP
. . . S (F03,F09,F53,F57)=0
. . . I $D(FOUND(2,R629,R629001)) S F03=1
. . . I $D(FOUND(3,R629,R629001)) S F09=1
. . . I $D(FOUND(4,R629,R629001)) S F53=1
. . . I $D(FOUND(5,R629,R629001)) S F57=1
. . . Q:(F03+F09+F53+F57)<1
. . . W !,?6
. . . S COMMA=0
. . . I F03+F09+F53+F57>1 S COMMA=1
. . . I F03 W "Specimen" W:F09+F53+F57>0 ", "
. . . I F09 W "Sample" W:F53+F57>0 ", "
. . . I F53 W "Non-HL7 Specimen" W:F57 ", "
. . . I F57 W "Non-HL7 Sample"
. . I $D(FOUND(1,R629)) W !
. ;
Q:STOP
D NP(.STOP)
Q:STOP
;
I 'STATUS W !!," N O M A T C H E S"
Q
;
NP(ABORT,PGNUM,HDR,FTR,BM) ;
; ABORT : <byref> Set if uses enters "^" at "MORE" prompt
; PGNUM : <byref> Page Number Counter
; HDR : Executable code to write the header
; FTR : Executable code to write the footer
; BM : Bottom Margin
N X
S PGNUM=$G(PGNUM)
S HDR=$G(HDR)
S FTR=$G(FTR)
S BM=$G(BM)
S:PGNUM<1 PGNUM=1
I $Y+1<($G(IOSL,24)-BM) Q
I FTR'="" X FTR
I $E($G(IOST),1,2)="C-" D Q:ABORT ;
. S X=$$MORE^LA7VLCM1()
. I X S ABORT=1 Q
S $Y=0
S PGNUM=PGNUM+1
I HDR'="" X HDR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7SRPT2 7993 printed Apr 09, 2024@20:46:21 Page 2
LA7SRPT2 ;DALOI/JDB - CODE USAGE REPORT ;03/07/12 09:04
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
+2 ;
+3 QUIT
+4 ;
ASK ;
+1 ; Prompts for Identifier and Coding System then performs search
+2 NEW SYS,ID,DIR,DTOUT,DUOUT,DIRUT,DIROUT,QUE,POP,%ZIS,QUE,X,Y,RTN
+3 SET DIR(0)="FAO"
+4 SET DIR("A")="Enter IDENTIFIER: "
+5 SET DIR("?")="Enter an identifier (ie 123-4)"
+6 DO ^DIR
+7 IF $EXTRACT(Y)="^"
QUIT
+8 IF $TRANSLATE(Y," ","")=""
QUIT
+9 SET ID=Y
+10 KILL DIR
+11 SET DIR(0)="FAO"
+12 SET DIR("A")="Enter CODING SYSTEM: "
+13 SET DIR("?")="Enter a coding system (ie LN)"
+14 DO ^DIR
+15 IF $EXTRACT(Y)="^"
QUIT
+16 IF $TRANSLATE(Y," ","")=""
QUIT
+17 SET SYS=Y
+18 SET RTN="MAIN^LA7VLCM8("""_ID_""","""_SYS_""")"
+19 SET QUE=$$QUE^LRUTIL(RTN,"PRINT CODE USAGE")
+20 IF QUE
QUIT
+21 ;
+22 DO MAIN(ID,SYS,"","")
+23 IF $EXTRACT(IOST,1,2)="C-"
DO MORE^LRUTIL()
+24 DO HOME^%ZIS
+25 QUIT
+26 ;
MAIN(CODE,SYS,MSGCFG,SHPCFG) ;
+1 NEW STOP
+2 SET CODE=$GET(CODE)
+3 SET SYS=$GET(SYS)
+4 SET MSGCFG=$GET(MSGCFG)
+5 SET SHPCFG=$GET(SHPCFG)
+6 USE IO
+7 SET STOP=0
+8 DO FIND(CODE,SYS,MSGCFG,SHPCFG,.STOP)
+9 ;
IF $DATA(ZTQUEUED)
Begin DoDot:1
+10 SET ZTREQ="@"
End DoDot:1
+11 DO ^%ZISC
+12 QUIT
+13 ;
FIND(CODE,SYS,MSGCFG,SHPCFG,STOP) ;
+1 ; Searches and displays search results for the code/code system
+2 ; in files #61,61.2,62,62.06,62.47,62.48,62.9
+3 ; Inputs
+4 ; CODE : Code (or Identifier)
+5 ; SYS : Coding System (ie "SCT")
+6 ; MSGCFG : <opt> Message Config (#62.48)
+7 ; SHPCFG : <opt> Shipping Config (#62.9)
+8 ; STOP : <byref> See Outputs
+9 ;
+10 ; Outputs
+11 ; STOP : Has user selected to stop the display
+12 ;
+13 NEW STATUS,FOUND,DATA,X,Y,DIERR
+14 NEW R61,R612,R62,R6206,R6247,R624701,R6248,R624802,R629,R629001
+15 SET CODE=$GET(CODE)
+16 SET SYS=$GET(SYS)
+17 SET MSGCFG=$GET(MSGCFG)
+18 SET SHPCFG=$GET(SHPCFG)
+19 SET STOP=0
+20 SET STATUS=0
+21 ;
IF SYS="SCT"
Begin DoDot:1
+22 SET X=$$CODE^LRSCT(CODE,"SCT",,"DATA")
+23 IF X<1
WRITE !,"Invalid SCT code"
+24 IF X>0
WRITE !,"SCT FSN: ",DATA("F")
End DoDot:1
+25 ;
+26 ;
IF SYS="LN"
Begin DoDot:1
+27 SET X=$$LOINCFSN^LA7VLCM1(CODE)
+28 IF X=""
WRITE !,"Invalid LOINC code"
+29 IF X'=""
WRITE !,"LOINC FSN: ",X
End DoDot:1
+30 ;
+31 DO NP(.STOP)
+32 if STOP
QUIT
+33 WRITE !!,"Checking TOPOGRAPHY file (#61)"
+34 KILL FOUND
+35 SET X=$$F61^LA7SRPT3(CODE,SYS,.FOUND)
+36 ;
IF 'X
Begin DoDot:1
+37 WRITE !,?5,"No matches"
End DoDot:1
+38 ;
IF X
Begin DoDot:1
+39 SET STATUS=1
+40 SET R61=0
+41 ;
FOR
SET R61=$ORDER(FOUND(1,R61))
if 'R61
QUIT
Begin DoDot:2
+42 SET DATA=$GET(^LAB(61,R61,0))
+43 SET X=$PIECE(DATA,U,1)
+44 WRITE !,?2,"#",R61,": ",X
+45 DO NP(.STOP)
End DoDot:2
if STOP
QUIT
End DoDot:1
+46 if STOP
QUIT
+47 DO NP(.STOP)
+48 if STOP
QUIT
+49 ;
+50 WRITE !!,"Checking ETIOLOGY FIELD (#61.2) file"
+51 KILL FOUND
+52 SET X=$$F612^LA7SRPT3(CODE,SYS,.FOUND)
+53 ;
IF 'X
Begin DoDot:1
+54 WRITE !,?5,"No matches"
End DoDot:1
+55 ;
IF X
Begin DoDot:1
+56 SET STATUS=1
+57 SET R612=0
+58 ;
FOR
SET R612=$ORDER(FOUND(1,R612))
if 'R612
QUIT
Begin DoDot:2
+59 SET DATA=$GET(^LAB(61.2,R612,0))
+60 SET X=$PIECE(DATA,U,1)
+61 WRITE !,?2,"#",R612,": ",X
+62 DO NP(.STOP)
End DoDot:2
if STOP
QUIT
+63 ;
End DoDot:1
+64 if STOP
QUIT
+65 DO NP(.STOP)
+66 if STOP
QUIT
+67 ;
+68 WRITE !!,"Checking COLLECTION SAMPLE (#62) file"
+69 KILL FOUND
+70 SET X=$$F62^LA7SRPT3(CODE,SYS,.FOUND)
+71 ;
IF 'X
Begin DoDot:1
+72 WRITE !,?5,"No matches"
End DoDot:1
+73 ;
IF X
Begin DoDot:1
+74 SET STATUS=1
+75 SET R62=0
+76 ;
FOR
SET R62=$ORDER(FOUND(1,R62))
if 'R62
QUIT
Begin DoDot:2
+77 SET DATA=$GET(^LAB(62,R62,0))
+78 SET X=$PIECE(DATA,U,1)
+79 WRITE !,?2,"#",R62,": ",X
+80 DO NP(.STOP)
End DoDot:2
if STOP
QUIT
+81 ;
End DoDot:1
+82 if STOP
QUIT
+83 DO NP(.STOP)
+84 if STOP
QUIT
+85 ;
+86 WRITE !!,"Checking ANTIMICROBIAL SUSCEPTIBILITY (#62.06) file"
+87 KILL FOUND
+88 SET X=$$F6206^LA7SRPT3(CODE,SYS,.FOUND)
+89 ;
IF 'X
Begin DoDot:1
+90 WRITE !,?5,"No matches"
End DoDot:1
+91 ;
IF X
Begin DoDot:1
+92 SET STATUS=1
+93 SET R6206=0
+94 ;
FOR
SET R6206=$ORDER(FOUND(1,R6206))
if 'R6206
QUIT
Begin DoDot:2
+95 SET DATA=$GET(^LAB(62.06,R6206,0))
+96 SET X=$PIECE(DATA,U,1)
+97 WRITE !,?2,"#",R6206,": ",X
+98 DO NP(.STOP)
End DoDot:2
if STOP
QUIT
+99 ;
End DoDot:1
+100 if STOP
QUIT
+101 DO NP(.STOP)
+102 if STOP
QUIT
+103 ;
+104 WRITE !!,"Checking LAB CODE MAPPING (#62.47) file"
+105 KILL FOUND
+106 SET X=$$F6247^LA7SRPT3(CODE,SYS,.FOUND,MSGCFG)
+107 ;
IF 'X
Begin DoDot:1
+108 WRITE !,?5,"No matches"
End DoDot:1
+109 ;
IF X
Begin DoDot:1
+110 NEW CONCEPT,LAMSG,LATARG,DIERR
+111 NEW F01,F22
+112 SET CONCEPT=""
+113 SET STATUS=1
+114 SET R6247=0
+115 ;
FOR
SET R6247=$ORDER(FOUND(1,R6247))
if 'R6247
QUIT
Begin DoDot:2
+116 SET R624701=0
+117 ;
FOR
SET R624701=$ORDER(FOUND(1,R6247,R624701))
if 'R624701
QUIT
Begin DoDot:3
+118 SET DATA=$GET(^LAB(62.47,R6247,0))
+119 SET X=$PIECE(DATA,U,1)
+120 IF CONCEPT'=X
if $ORDER(FOUND(1,0))'=R6247
WRITE !
WRITE !,?2,X," (#62.47:",R6247,")"
SET CONCEPT=X
+121 DO NP(.STOP)
+122 if STOP
QUIT
+123 SET DATA=$GET(^LAB(62.47,R6247,1,R624701,0))
+124 SET F01=$PIECE(DATA,U,1)
+125 KILL LATARG,DIERR,LAMSG
+126 DO GETS^DIQ(62.4701,R624701_","_R6247_",",2.2,"EI","LATARG","LAMSG")
+127 SET R6248=$GET(LATARG(62.4701,R624701_","_R6247_",",2.2,"I"))
+128 SET F22=$GET(LATARG(62.4701,R624701_","_R6247_",",2.2,"E"))
+129 IF F22=""
SET F22="No Message Config"
+130 WRITE !,?4,"#",R624701,": ",F01," (",F22,")"
+131 DO NP(.STOP)
+132 if STOP
QUIT
+133 ;
Begin DoDot:4
+134 ;
IF SYS'="SCT"
Begin DoDot:5
+135 SET X=$$HL2LAH^LA7VHLU6(CODE,"",SYS,1,R6248)
+136 IF X'=""
WRITE !,?6,"$$HL2LAH:",X
End DoDot:5
+137 ;
IF SYS'="LN"
Begin DoDot:5
+138 SET Y=$$HL2VA^LA7VHLU6(CODE,"",SYS,1,R6247,R6248)
+139 IF Y'=""
if X=""
WRITE !,?6
if X'=""
WRITE " "
WRITE "$$HL2VA:",Y
End DoDot:5
End DoDot:4
+140 DO NP(.STOP)
+141 if STOP
QUIT
+142 IF $ORDER(FOUND(1,R6247,R624701))
WRITE !
+143 ;
End DoDot:3
if STOP
QUIT
+144 ;
End DoDot:2
if STOP
QUIT
+145 ;
End DoDot:1
+146 if STOP
QUIT
+147 DO NP(.STOP)
+148 if STOP
QUIT
+149 ;
+150 WRITE !!,"Checking LA7 MESSAGE PARAMETER (#62.48) file"
+151 KILL FOUND
+152 SET X=$$F6248^LA7SRPT3(CODE,SYS,.FOUND,MSGCFG)
+153 ;
IF 'X
Begin DoDot:1
+154 WRITE !,?5,"No matches"
End DoDot:1
+155 ;
IF X
Begin DoDot:1
+156 NEW CONFIG,VAENTRY,NL
+157 SET CONFIG=""
+158 SET STATUS=1
+159 SET R6248=0
+160 ;
FOR
SET R6248=$ORDER(FOUND(1,R6248))
if 'R6248
QUIT
Begin DoDot:2
+161 SET DATA=$GET(^LAHM(62.48,R6248,0))
+162 SET X=$PIECE(DATA,U,1)
+163 IF CONFIG'=X
WRITE !,?2,X," (#62.48:",R6248,")"
SET CONFIG=X
WRITE !,?2,"NON-VA ORDER SNOMED CODES sub-file"
+164 DO NP(.STOP)
+165 if STOP
QUIT
+166 SET R624802=0
+167 ;
FOR
SET R624802=$ORDER(FOUND(1,R6248,R624802))
if 'R624802
QUIT
Begin DoDot:3
+168 SET DATA=$GET(^LAHM(62.48,R6248,"SCT",R624802,0))
+169 SET VAENTRY=$PIECE(DATA,U,1)
+170 SET X=$PIECE(VAENTRY,";",2)_":"_$PIECE(VAENTRY,";",1)
+171 SET X=$PIECE(X,"(",2)
+172 SET X=$TRANSLATE(X,",","")
+173 SET NL=0
+174 WRITE !,?4,"#",R624802,": ",$$VARPTR01^LA7XREF(VAENTRY)," (#",X,")"
+175 DO NP(.STOP)
+176 if STOP
QUIT
+177 ;
IF $DATA(FOUND(2,R6248,R624802))
Begin DoDot:4
+178 WRITE !,?6," .01 is mapped"
SET NL=1
End DoDot:4
+179 ;
+180 ;
IF $DATA(FOUND(3,R6248,R624802))
Begin DoDot:4
+181 if 'NL
WRITE !,?6
if NL
WRITE ", "
WRITE "Used as override"
End DoDot:4
+182 IF $ORDER(FOUND(1,R6248,R624802))
WRITE !
+183 DO NP(.STOP)
End DoDot:3
if STOP
QUIT
+184 ;
End DoDot:2
if STOP
QUIT
+185 ;
End DoDot:1
+186 if STOP
QUIT
+187 DO NP(.STOP)
+188 if STOP
QUIT
+189 ;
+190 WRITE !!,"Checking LAB SHIPPING CONFIGURATION (#62.9) file"
+191 KILL FOUND
+192 SET X=$$F629^LA7SRPT3(CODE,SYS,.FOUND,SHPCFG)
+193 ;
IF 'X
Begin DoDot:1
+194 WRITE !,?5,"No matches"
End DoDot:1
+195 ;
IF X
Begin DoDot:1
+196 NEW CONFIG,TEST,F03,F09,F53,F57,DIERR,LAMSG,COMMA
+197 SET (CONFIG,TEST)=""
+198 SET (F03,F09,F53,F57)=0
+199 SET STATUS=1
+200 SET R629=0
+201 ;
FOR
SET R629=$ORDER(FOUND(1,R629))
if 'R629
QUIT
Begin DoDot:2
+202 SET DATA=$GET(^LAHM(62.9,R629,0))
+203 SET X=$PIECE(DATA,U,1)
+204 IF CONFIG'=X
WRITE !,?2,X," (#62.9:",R629,")"
SET CONFIG=X
+205 DO NP(.STOP)
+206 if STOP
QUIT
+207 SET R629001=0
+208 SET TEST=""
+209 ;
FOR
SET R629001=$ORDER(FOUND(1,R629,R629001))
if 'R629001
QUIT
Begin DoDot:3
+210 SET DATA=$GET(^LAHM(62.9,R629,60,R629001,0))
+211 SET X=$PIECE(DATA,U,1)
+212 KILL LAMSG,DIERR
+213 SET X=$$GET1^DIQ(60,X_",",.01,"E","","LAMSG")
+214 IF TEST'=X
WRITE !,?4,"Test Profile"
WRITE !,?4,"#",R629001,": ",X
SET TEST=X
+215 DO NP(.STOP)
+216 if STOP
QUIT
+217 SET (F03,F09,F53,F57)=0
+218 IF $DATA(FOUND(2,R629,R629001))
SET F03=1
+219 IF $DATA(FOUND(3,R629,R629001))
SET F09=1
+220 IF $DATA(FOUND(4,R629,R629001))
SET F53=1
+221 IF $DATA(FOUND(5,R629,R629001))
SET F57=1
+222 if (F03+F09+F53+F57)<1
QUIT
+223 WRITE !,?6
+224 SET COMMA=0
+225 IF F03+F09+F53+F57>1
SET COMMA=1
+226 IF F03
WRITE "Specimen"
if F09+F53+F57>0
WRITE ", "
+227 IF F09
WRITE "Sample"
if F53+F57>0
WRITE ", "
+228 IF F53
WRITE "Non-HL7 Specimen"
if F57
WRITE ", "
+229 IF F57
WRITE "Non-HL7 Sample"
End DoDot:3
if STOP
QUIT
+230 IF $DATA(FOUND(1,R629))
WRITE !
End DoDot:2
if STOP
QUIT
+231 ;
End DoDot:1
+232 if STOP
QUIT
+233 DO NP(.STOP)
+234 if STOP
QUIT
+235 ;
+236 IF 'STATUS
WRITE !!," N O M A T C H E S"
+237 QUIT
+238 ;
NP(ABORT,PGNUM,HDR,FTR,BM) ;
+1 ; ABORT : <byref> Set if uses enters "^" at "MORE" prompt
+2 ; PGNUM : <byref> Page Number Counter
+3 ; HDR : Executable code to write the header
+4 ; FTR : Executable code to write the footer
+5 ; BM : Bottom Margin
+6 NEW X
+7 SET PGNUM=$GET(PGNUM)
+8 SET HDR=$GET(HDR)
+9 SET FTR=$GET(FTR)
+10 SET BM=$GET(BM)
+11 if PGNUM<1
SET PGNUM=1
+12 IF $Y+1<($GET(IOSL,24)-BM)
QUIT
+13 IF FTR'=""
XECUTE FTR
+14 ;
IF $EXTRACT($GET(IOST),1,2)="C-"
Begin DoDot:1
+15 SET X=$$MORE^LA7VLCM1()
+16 IF X
SET ABORT=1
QUIT
End DoDot:1
if ABORT
QUIT
+17 SET $Y=0
+18 SET PGNUM=PGNUM+1
+19 IF HDR'=""
XECUTE HDR
+20 QUIT
