BLRAG05A ; IHS/MSC/SAT - SUPPORT FOR LABORATORY ACCESSION GUI RPCS ; 05-Apr-2016 08:52 ; MKK
;;5.2;IHS LABORATORY;**1031,1039**;NOV 01, 1997;Build 38
;
; Reference to File #3.5 supported by DBIA #2469
;
1 ;
S U="^" Q:$D(LRLABLIO)
;
N %ZIS,DIR,DIRUT,DTOUT,DUOUT,IOP,LRLABEL,POP,X,Y
;
; Setup handle for user's "HOME" device.
D OPEN^%ZISUTL("LRHOME","HOME")
;
S %ZIS("B")="LABLABEL"
;
; Check if label device assigned to this user's HOME Device file entry.
I $G(IOS) D
. S X=$$GET1^DIQ(3.5,IOS_",",101,"E")
. I $L(X) S %ZIS("B")=X
;
I %ZIS("B")="LABLABEL",$D(^LAB(69.9,1,3.5,+$G(DUZ(2)),0)) D
. ; Get this division's default printer
. S %ZIS("B")=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,3)
;I %ZIS("B")="" S %ZIS("B")="LABLABEL"
;S %ZIS("A")="Print labels on: ",%ZIS="NQ"
S IOP=%ZIS("B")
; Setup handle for user's LABEL device.
2 D OPEN^%ZISUTL("LRLABEL",IOP)
; I POP!(IO=IO(0)) D BD Q
;----- BEGIN IHS/OIT/MKK MOD LR*5.2*1022
; If OR half of the above IF statement, (IO=IO(0)), is left in,
; then it is impossible to test printer to the screen.
I POP D BD Q
;----- END IHS/OIT/MKK MOD LR*5.2*1022
S LRLABLIO=ION_";"_IOST_";"_IOM_";"_IOSL
I $D(IO("Q")) S LRLABLIO("Q")=1
I $E(IOST,1)'="P" D G:Y'=1 2
. N DIR,DIRUT,DTOUT,DUOUT
. D USE^%ZISUTL("LRHOME")
. ;S DIR(0)="YAO",DIR("A",1)="NOT printing on a printer.",DIR("A")="Are you sure?"
. ;----- BEGIN IHS/OIT/MKK MOD LR*5.2*1022
. S DIR(0)="YAO"
. S DIR("A",1)=" NOT printing on a printer."
. S DIR("A",2)=" "
. S DIR("A")=" Is this correct? "
. S DIR("B")="YES"
. ;----- END IHS/OIT/MKK MOD LR*5.2*1022
. D ^DIR
; Device on another cpu, can't test.
I $D(IOCPU) D Q
. N MSG
. S MSG="Device "_ION_" is on CPU '"_IOCPU_"' - Unable to test"
. D USE^%ZISUTL("LRHOME")
. D EN^DDIOL(MSG,"","!?5")
. D K
;
3 I $D(LRLABLIO("Q")) D K Q
D USE^%ZISUTL("LRHOME")
/*
W !
K DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="YAO",DIR("A")="Do you wish to test the label printer: ",DIR("B")="NO"
S DIR("?")="Enter 'YES' if you want to test the printer, 'NO' if you do not."
D ^DIR
I $D(DIRUT) D BD Q
*/
S Y=0
I Y<1 G K ; Don't want to test; Note: this is not a kill, it is a GO to tag K (SAC catching these as a KILL)
D OPEN^%ZISUTL("LRLABEL",LRLABLIO)
I POP D G 1
. D USE^%ZISUTL("LRHOME")
. D EN^DDIOL("Device in use - try later","","!")
. K LRLABLIO
N LRAA
S LRAA=0
D LBLTYP^LRLABLD
;
T ; Print test label
D USE^%ZISUTL("LRHOME")
K DIR,DIRUT,DTOUT,DUOUT,X,Y
W !!,"Using label routine: ",LRLABEL,!
S DIR(0)="E"
S DIR("A",1)="Load and position label stock as appropriate for this printer."
S DIR("A")="Press return when ready"
D ^DIR
I Y'=1 D BD Q
;
N I,N,PNM,SSN
N LRACC,LRBAR,LRBARID,LRCE,LRDAT,LRINFW,LRLLOC,LRPREF,LRAN,LRRB,LRTOP,LRTS,LRUID,LRURG,LRURG0,LRURGA,LRXL
NEW DOB,SEX ; IHS/OIT/MKK - LR*5.2*1027
;
; Set up variables for test label
S PNM="TEST-LABEL-DO-NOT-USE",SSN="000-00-0000P",LRDAT="XX/XX/XX",LRLLOC="LAB",LRRB=1
S LRACC="SITE-TEST-LABEL",LRCE="9999999",LRPREF="SMALL "
S LRTOP="TEST-TUBE",LRTS(1)="Don't-use",LRTS(2)="this-label"
S LRINFW="Patient-info-field",(LRBARID,LRUID)="0000000000",LRAN="000",I=1,N=1,LRXL=0
S (LRURG,LRURG0)=1
S LRURGA=$$URGA^LRLABLD(LRURG0)
; ----- BEGIN IHS/OIT/MKK MOD LR*5.2*1022
S LRAA=0
S LRAD=0
S PROV="TEST,PROV"
S DOB="XX/XX/XX"
S SEX="X"
; ----- END IHS/OIT/MKK MOD LR*5.2*1022
;
D LRBAR^LRLABLD
D USE^%ZISUTL("LRLABEL"),@LRLABEL
D USE^%ZISUTL("LRHOME")
;
K DIR,DIRUT,DTOUT,DUOUT,X,Y
W !
S DIR(0)="YAO",DIR("A")="Label OK: ",DIR("B")="YES"
S DIR("?")="Enter 'YES' if label printed correctly, 'NO' if it did not."
D ^DIR
I $D(DIRUT) G BD
I Y=1 G K ;Note: this is not a kill, it is a GO to tag K (SAC catching these as a KILL)
;
K DIR,DIRUT,DTOUT,DUOUT,X,Y
/*
W !
S DIR(0)="YAO",DIR("A")="Test printer again: ",DIR("B")="YES"
S DIR("?")="Enter 'YES' to test label printing, 'NO' to quit testing."
D ^DIR
I $D(DIRUT) G BD
*/
S Y=0
I Y=1 G T
G K ;Note: this is not a kill, it is a GO to tag K (SAC catching these as a KILL)
;
BD ; Bad device - abort, timeout, unsuccessful selection
K LRLABLIO
D UNL69ERR^BLRAG05D
D ERR^BLRAGUT("BLRAGP5A: Print error")
K ; Close devices
D CLOSE^%ZISUTL("LRLABEL")
D CLOSE^%ZISUTL("LRHOME")
Q
;
BLRTSTL(BLRTSTL) ;collect all tests for each specimen
; .BLRTSTL = (required) If all tests for a given specimen were not selected
; and passed in, BLRTSTL will be returned with all tests
; that are associated with the specimens represented in
; this input.
; The "TEST POINTERS" portion of this data comes
; element 39 in the return from BLR ALL NON-ACCESSIONED.
; List of test pointers with ICD9 pointers for each
; test/procedure being accessioned separated by ^.
; Each ^ piece is made up of these pipe pieces:
; TEST POINTERS | [ICD9_IEN:ICD9_IEN:...] ^ ...
; Test pointers = pointers to the LAB ORDER ENTRY
; file 69 - DATE:SPECIMEN:TEST
; ICD9_IEN - pointer to ICD DIAGNOSIS file 80
;
N BLRJ,BLRTN
N BLRTSTA ;BLRTSTA(<DATE>,<SPECIMEN>,<TEST>)=<ICD9-POINTERS>
; ;BLRTSTA(<DATE>,<SPECIMEN>)=<ICD9-POINTERS>
N LRODT,LRSN,LRTN
S BLRTSTL=$G(BLRTSTL)
K BLRTSTA
;put initial tests into the array
F BLRJ=1:1:$L(BLRTSTL,U) D
.S LRODT=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",1)
.S LRSN=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",2)
.S LRTN=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",3)
.S BLRTSTA(LRODT,LRSN,LRTN)=$P($P(BLRTSTL,U,BLRJ),"|",2)
.I $P($P(BLRTSTL,U,BLRJ),"|",2),$G(BLRTSTA(LRODT,LRSN))="" S BLRTSTA(LRODT,LRSN)=$P($P(BLRTSTL,U,BLRJ),"|",2)
;add missing tests to the array
F BLRJ=1:1:$L(BLRTSTL,U) D
.S LRODT=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",1)
.S LRSN=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",2)
.S LRTN=0 F S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:LRTN<1 D
..Q:$D(BLRTSTA(LRODT,LRSN,LRTN))
..S BLRTSTA(LRODT,LRSN,LRTN)=$G(BLRTSTA(LRODT,LRSN))
S BLRTSTL=""
S LRODT=0
F S LRODT=$O(BLRTSTA(LRODT)) Q:LRODT'>0 D
.S LRSN=0 F S LRSN=$O(BLRTSTA(LRODT,LRSN)) Q:LRSN'>0 D
..S LRTN=0 F S LRTN=$O(BLRTSTA(LRODT,LRSN,LRTN)) Q:LRTN'>0 D
...S BLRICD=BLRTSTA(LRODT,LRSN,LRTN)
...S:BLRICD="" BLRICD=$G(BLRTSTA(LRODT,LRSN))
...S BLRTSTL=BLRTSTL_$S(BLRTSTL'="":"^",1:"")_LRODT_":"_LRSN_":"_LRTN_"|"_BLRICD
;
K BLRTSTA
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
STORF69D(LRODT,LRSP,LROT,ICDSTR) ; EP - Called from STORDIAG^BLRAG05.
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,ICDSTR,LRODT,LRSP,LROT,U,XPARSYS,XQXFLG)
;
; Store ICD code(s) into Lab Order Entry (#69) file
S LROTIEN=LROT_","_LRSP_","_LRODT_","
F ICDCNT=1:1:$L(ICDSTR,":") D
. S ICDIEN=$P(ICDSTR,":",ICDCNT)
. ;
. ; Skip if UNCODED DIAGNOSIS
. Q:$$GET1^DIQ(80,ICDIEN,.01)=".9999"!($$GET1^DIQ(80,ICDIEN,.01)="ZZZ.999")
. ;
. K ERRS,FDA
. S FDA(69.05,"?+1,"_LROTIEN,.01)=ICDIEN
. D UPDATE^DIE("S","FDA",,"ERRS")
. I $D(ERRS) D
.. S ^XTMP("BLRAG05",0)=$$HTFM^XLFDT(+$H+90)_U_$$DT^XLFDT_U_"GUI Accessioning ICD Code Error"
.. M ^XTMP("BLRAG05",$J,"STORF69D",$H,"FDA")=FDA
.. M ^XTMP("BLRAG05",$J,"STORF69D",$H,"ERRS")=ERRS
Q
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
BLRAG05A ; IHS/MSC/SAT - SUPPORT FOR LABORATORY ACCESSION GUI RPCS ; 05-Apr-2016 08:52 ; MKK
+1 ;;5.2;IHS LABORATORY;**1031,1039**;NOV 01, 1997;Build 38
+2 ;
+3 ; Reference to File #3.5 supported by DBIA #2469
+4 ;
1 ;
+1 SET U="^"
IF $DATA(LRLABLIO)
QUIT
+2 ;
+3 NEW %ZIS,DIR,DIRUT,DTOUT,DUOUT,IOP,LRLABEL,POP,X,Y
+4 ;
+5 ; Setup handle for user's "HOME" device.
+6 DO OPEN^%ZISUTL("LRHOME","HOME")
+7 ;
+8 SET %ZIS("B")="LABLABEL"
+9 ;
+10 ; Check if label device assigned to this user's HOME Device file entry.
+11 IF $GET(IOS)
Begin DoDot:1
+12 SET X=$$GET1^DIQ(3.5,IOS_",",101,"E")
+13 IF $LENGTH(X)
SET %ZIS("B")=X
End DoDot:1
+14 ;
+15 IF %ZIS("B")="LABLABEL"
IF $DATA(^LAB(69.9,1,3.5,+$GET(DUZ(2)),0))
Begin DoDot:1
+16 ; Get this division's default printer
+17 SET %ZIS("B")=$PIECE($GET(^LAB(69.9,1,3.5,+DUZ(2),0)),U,3)
End DoDot:1
+18 ;I %ZIS("B")="" S %ZIS("B")="LABLABEL"
+19 ;S %ZIS("A")="Print labels on: ",%ZIS="NQ"
+20 SET IOP=%ZIS("B")
+21 ; Setup handle for user's LABEL device.
2 DO OPEN^%ZISUTL("LRLABEL",IOP)
+1 ; I POP!(IO=IO(0)) D BD Q
+2 ;----- BEGIN IHS/OIT/MKK MOD LR*5.2*1022
+3 ; If OR half of the above IF statement, (IO=IO(0)), is left in,
+4 ; then it is impossible to test printer to the screen.
+5 IF POP
DO BD
QUIT
+6 ;----- END IHS/OIT/MKK MOD LR*5.2*1022
+7 SET LRLABLIO=ION_";"_IOST_";"_IOM_";"_IOSL
+8 IF $DATA(IO("Q"))
SET LRLABLIO("Q")=1
+9 IF $EXTRACT(IOST,1)'="P"
Begin DoDot:1
+10 NEW DIR,DIRUT,DTOUT,DUOUT
+11 DO USE^%ZISUTL("LRHOME")
+12 ;S DIR(0)="YAO",DIR("A",1)="NOT printing on a printer.",DIR("A")="Are you sure?"
+13 ;----- BEGIN IHS/OIT/MKK MOD LR*5.2*1022
+14 SET DIR(0)="YAO"
+15 SET DIR("A",1)=" NOT printing on a printer."
+16 SET DIR("A",2)=" "
+17 SET DIR("A")=" Is this correct? "
+18 SET DIR("B")="YES"
+19 ;----- END IHS/OIT/MKK MOD LR*5.2*1022
+20 DO ^DIR
End DoDot:1
IF Y'=1
GOTO 2
+21 ; Device on another cpu, can't test.
+22 IF $DATA(IOCPU)
Begin DoDot:1
+23 NEW MSG
+24 SET MSG="Device "_ION_" is on CPU '"_IOCPU_"' - Unable to test"
+25 DO USE^%ZISUTL("LRHOME")
+26 DO EN^DDIOL(MSG,"","!?5")
+27 DO K
End DoDot:1
QUIT
+28 ;
3 IF $DATA(LRLABLIO("Q"))
DO K
QUIT
+1 DO USE^%ZISUTL("LRHOME")
+2
*** ERROR ***
+3 WRITE !
+4 KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
+5 SET DIR(0)="YAO"
SET DIR("A")="Do you wish to test the label printer: "
SET DIR("B")="NO"
+6 SET DIR("?")="Enter 'YES' if you want to test the printer, 'NO' if you do not."
+7 DO ^DIR
+8 IF $DATA(DIRUT)
DO BD
QUIT
+9
*** ERROR ***
+10 SET Y=0
+11 ; Don't want to test; Note: this is not a kill, it is a GO to tag K (SAC catching these as a KILL)
IF Y<1
GOTO K
+12 DO OPEN^%ZISUTL("LRLABEL",LRLABLIO)
+13 IF POP
Begin DoDot:1
+14 DO USE^%ZISUTL("LRHOME")
+15 DO EN^DDIOL("Device in use - try later","","!")
+16 KILL LRLABLIO
End DoDot:1
GOTO 1
+17 NEW LRAA
+18 SET LRAA=0
+19 DO LBLTYP^LRLABLD
+20 ;
T ; Print test label
+1 DO USE^%ZISUTL("LRHOME")
+2 KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
+3 WRITE !!,"Using label routine: ",LRLABEL,!
+4 SET DIR(0)="E"
+5 SET DIR("A",1)="Load and position label stock as appropriate for this printer."
+6 SET DIR("A")="Press return when ready"
+7 DO ^DIR
+8 IF Y'=1
DO BD
QUIT
+9 ;
+10 NEW I,N,PNM,SSN
+11 NEW LRACC,LRBAR,LRBARID,LRCE,LRDAT,LRINFW,LRLLOC,LRPREF,LRAN,LRRB,LRTOP,LRTS,LRUID,LRURG,LRURG0,LRURGA,LRXL
+12 ; IHS/OIT/MKK - LR*5.2*1027
NEW DOB,SEX
+13 ;
+14 ; Set up variables for test label
+15 SET PNM="TEST-LABEL-DO-NOT-USE"
SET SSN="000-00-0000P"
SET LRDAT="XX/XX/XX"
SET LRLLOC="LAB"
SET LRRB=1
+16 SET LRACC="SITE-TEST-LABEL"
SET LRCE="9999999"
SET LRPREF="SMALL "
+17 SET LRTOP="TEST-TUBE"
SET LRTS(1)="Don't-use"
SET LRTS(2)="this-label"
+18 SET LRINFW="Patient-info-field"
SET (LRBARID,LRUID)="0000000000"
SET LRAN="000"
SET I=1
SET N=1
SET LRXL=0
+19 SET (LRURG,LRURG0)=1
+20 SET LRURGA=$$URGA^LRLABLD(LRURG0)
+21 ; ----- BEGIN IHS/OIT/MKK MOD LR*5.2*1022
+22 SET LRAA=0
+23 SET LRAD=0
+24 SET PROV="TEST,PROV"
+25 SET DOB="XX/XX/XX"
+26 SET SEX="X"
+27 ; ----- END IHS/OIT/MKK MOD LR*5.2*1022
+28 ;
+29 DO LRBAR^LRLABLD
+30 DO USE^%ZISUTL("LRLABEL")
DO @LRLABEL
+31 DO USE^%ZISUTL("LRHOME")
+32 ;
+33 KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
+34 WRITE !
+35 SET DIR(0)="YAO"
SET DIR("A")="Label OK: "
SET DIR("B")="YES"
+36 SET DIR("?")="Enter 'YES' if label printed correctly, 'NO' if it did not."
+37 DO ^DIR
+38 IF $DATA(DIRUT)
GOTO BD
+39 ;Note: this is not a kill, it is a GO to tag K (SAC catching these as a KILL)
IF Y=1
GOTO K
+40 ;
+41 KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
+42
*** ERROR ***
+43 WRITE !
+44 SET DIR(0)="YAO"
SET DIR("A")="Test printer again: "
SET DIR("B")="YES"
+45 SET DIR("?")="Enter 'YES' to test label printing, 'NO' to quit testing."
+46 DO ^DIR
+47 IF $DATA(DIRUT)
GOTO BD
+48
*** ERROR ***
+49 SET Y=0
+50 IF Y=1
GOTO T
+51 ;Note: this is not a kill, it is a GO to tag K (SAC catching these as a KILL)
GOTO K
+52 ;
BD ; Bad device - abort, timeout, unsuccessful selection
+1 KILL LRLABLIO
+2 DO UNL69ERR^BLRAG05D
+3 DO ERR^BLRAGUT("BLRAGP5A: Print error")
K ; Close devices
+1 DO CLOSE^%ZISUTL("LRLABEL")
+2 DO CLOSE^%ZISUTL("LRHOME")
+3 QUIT
+4 ;
BLRTSTL(BLRTSTL) ;collect all tests for each specimen
+1 ; .BLRTSTL = (required) If all tests for a given specimen were not selected
+2 ; and passed in, BLRTSTL will be returned with all tests
+3 ; that are associated with the specimens represented in
+4 ; this input.
+5 ; The "TEST POINTERS" portion of this data comes
+6 ; element 39 in the return from BLR ALL NON-ACCESSIONED.
+7 ; List of test pointers with ICD9 pointers for each
+8 ; test/procedure being accessioned separated by ^.
+9 ; Each ^ piece is made up of these pipe pieces:
+10 ; TEST POINTERS | [ICD9_IEN:ICD9_IEN:...] ^ ...
+11 ; Test pointers = pointers to the LAB ORDER ENTRY
+12 ; file 69 - DATE:SPECIMEN:TEST
+13 ; ICD9_IEN - pointer to ICD DIAGNOSIS file 80
+14 ;
+15 NEW BLRJ,BLRTN
+16 ;BLRTSTA(<DATE>,<SPECIMEN>,<TEST>)=<ICD9-POINTERS>
NEW BLRTSTA
+17 ; ;BLRTSTA(<DATE>,<SPECIMEN>)=<ICD9-POINTERS>
+18 NEW LRODT,LRSN,LRTN
+19 SET BLRTSTL=$GET(BLRTSTL)
+20 KILL BLRTSTA
+21 ;put initial tests into the array
+22 FOR BLRJ=1:1:$LENGTH(BLRTSTL,U)
Begin DoDot:1
+23 SET LRODT=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",1)
+24 SET LRSN=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",2)
+25 SET LRTN=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",3)
+26 SET BLRTSTA(LRODT,LRSN,LRTN)=$PIECE($PIECE(BLRTSTL,U,BLRJ),"|",2)
+27 IF $PIECE($PIECE(BLRTSTL,U,BLRJ),"|",2)
IF $GET(BLRTSTA(LRODT,LRSN))=""
SET BLRTSTA(LRODT,LRSN)=$PIECE($PIECE(BLRTSTL,U,BLRJ),"|",2)
End DoDot:1
+28 ;add missing tests to the array
+29 FOR BLRJ=1:1:$LENGTH(BLRTSTL,U)
Begin DoDot:1
+30 SET LRODT=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",1)
+31 SET LRSN=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",2)
+32 SET LRTN=0
FOR
SET LRTN=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTN))
IF LRTN<1
QUIT
Begin DoDot:2
+33 IF $DATA(BLRTSTA(LRODT,LRSN,LRTN))
QUIT
+34 SET BLRTSTA(LRODT,LRSN,LRTN)=$GET(BLRTSTA(LRODT,LRSN))
End DoDot:2
End DoDot:1
+35 SET BLRTSTL=""
+36 SET LRODT=0
+37 FOR
SET LRODT=$ORDER(BLRTSTA(LRODT))
IF LRODT'>0
QUIT
Begin DoDot:1
+38 SET LRSN=0
FOR
SET LRSN=$ORDER(BLRTSTA(LRODT,LRSN))
IF LRSN'>0
QUIT
Begin DoDot:2
+39 SET LRTN=0
FOR
SET LRTN=$ORDER(BLRTSTA(LRODT,LRSN,LRTN))
IF LRTN'>0
QUIT
Begin DoDot:3
+40 SET BLRICD=BLRTSTA(LRODT,LRSN,LRTN)
+41 IF BLRICD=""
SET BLRICD=$GET(BLRTSTA(LRODT,LRSN))
+42 SET BLRTSTL=BLRTSTL_$SELECT(BLRTSTL'="":"^",1:"")_LRODT_":"_LRSN_":"_LRTN_"|"_BLRICD
End DoDot:3
End DoDot:2
End DoDot:1
+43 ;
+44 KILL BLRTSTA
+45 QUIT
+46 ;
+47 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
STORF69D(LRODT,LRSP,LROT,ICDSTR) ; EP - Called from STORDIAG^BLRAG05.
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,ICDSTR,LRODT,LRSP,LROT,U,XPARSYS,XQXFLG)
+2 ;
+3 ; Store ICD code(s) into Lab Order Entry (#69) file
+4 SET LROTIEN=LROT_","_LRSP_","_LRODT_","
+5 FOR ICDCNT=1:1:$LENGTH(ICDSTR,":")
Begin DoDot:1
+6 SET ICDIEN=$PIECE(ICDSTR,":",ICDCNT)
+7 ;
+8 ; Skip if UNCODED DIAGNOSIS
+9 IF $$GET1^DIQ(80,ICDIEN,.01)=".9999"!($$GET1^DIQ(80,ICDIEN,.01)="ZZZ.999")
QUIT
+10 ;
+11 KILL ERRS,FDA
+12 SET FDA(69.05,"?+1,"_LROTIEN,.01)=ICDIEN
+13 DO UPDATE^DIE("S","FDA",,"ERRS")
+14 IF $DATA(ERRS)
Begin DoDot:2
+15 SET ^XTMP("BLRAG05",0)=$$HTFM^XLFDT(+$HOROLOG+90)_U_$$DT^XLFDT_U_"GUI Accessioning ICD Code Error"
+16 MERGE ^XTMP("BLRAG05",$JOB,"STORF69D",$HOROLOG,"FDA")=FDA
+17 MERGE ^XTMP("BLRAG05",$JOB,"STORF69D",$HOROLOG,"ERRS")=ERRS
End DoDot:2
End DoDot:1
+18 QUIT
+19 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
