- 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