Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRAG05A

BLRAG05A.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ; Reference to File #3.5 supported by DBIA #2469
  1.  ;
  1. 1 ;
  1.  S U="^" Q:$D(LRLABLIO)
  1.  ;
  1.  N %ZIS,DIR,DIRUT,DTOUT,DUOUT,IOP,LRLABEL,POP,X,Y
  1.  ;
  1.  ; Setup handle for user's "HOME" device.
  1.  D OPEN^%ZISUTL("LRHOME","HOME")
  1.  ;
  1.  S %ZIS("B")="LABLABEL"
  1.  ;
  1.  ; Check if label device assigned to this user's HOME Device file entry.
  1.  I $G(IOS) D
  1.  . S X=$$GET1^DIQ(3.5,IOS_",",101,"E")
  1.  . I $L(X) S %ZIS("B")=X
  1.  ;
  1.  I %ZIS("B")="LABLABEL",$D(^LAB(69.9,1,3.5,+$G(DUZ(2)),0)) D
  1.  . ; Get this division's default printer
  1.  . S %ZIS("B")=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,3)
  1.  ;I %ZIS("B")="" S %ZIS("B")="LABLABEL"
  1.  ;S %ZIS("A")="Print labels on: ",%ZIS="NQ"
  1.  S IOP=%ZIS("B")
  1.  ; Setup handle for user's LABEL device.
  1. 2 D OPEN^%ZISUTL("LRLABEL",IOP)
  1.  ; I POP!(IO=IO(0)) D BD Q
  1.  ;----- BEGIN IHS/OIT/MKK MOD LR*5.2*1022
  1.  ;      If OR half of the above IF statement, (IO=IO(0)), is left in,
  1.  ;      then it is impossible to test printer to the screen.
  1.  I POP D BD Q
  1.  ;----- END IHS/OIT/MKK MOD LR*5.2*1022
  1.  S LRLABLIO=ION_";"_IOST_";"_IOM_";"_IOSL
  1.  I $D(IO("Q")) S LRLABLIO("Q")=1
  1.  I $E(IOST,1)'="P" D  G:Y'=1 2
  1.  . N DIR,DIRUT,DTOUT,DUOUT
  1.  . D USE^%ZISUTL("LRHOME")
  1.  . ;S DIR(0)="YAO",DIR("A",1)="NOT printing on a printer.",DIR("A")="Are you sure?"
  1.  . ;----- BEGIN IHS/OIT/MKK MOD LR*5.2*1022
  1.  . S DIR(0)="YAO"
  1.  . S DIR("A",1)="     NOT printing on a printer."
  1.  . S DIR("A",2)=" "
  1.  . S DIR("A")="     Is this correct? "
  1.  . S DIR("B")="YES"
  1.  . ;----- END IHS/OIT/MKK MOD LR*5.2*1022
  1.  . D ^DIR
  1.  ; Device on another cpu, can't test.
  1.  I $D(IOCPU) D  Q
  1.  . N MSG
  1.  . S MSG="Device "_ION_" is on CPU '"_IOCPU_"' - Unable to test"
  1.  . D USE^%ZISUTL("LRHOME")
  1.  . D EN^DDIOL(MSG,"","!?5")
  1.  . D K
  1.  ;
  1. 3 I $D(LRLABLIO("Q")) D K Q
  1.  D USE^%ZISUTL("LRHOME")
  1.  /*
  1.  W !
  1.  K DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DIR(0)="YAO",DIR("A")="Do you wish to test the label printer: ",DIR("B")="NO"
  1.  S DIR("?")="Enter 'YES' if you want to test the printer, 'NO' if you do not."
  1.  D ^DIR
  1.  I $D(DIRUT) D BD Q
  1.  */
  1.  S Y=0
  1.  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)
  1.  D OPEN^%ZISUTL("LRLABEL",LRLABLIO)
  1.  I POP D  G 1
  1.  . D USE^%ZISUTL("LRHOME")
  1.  . D EN^DDIOL("Device in use - try later","","!")
  1.  . K LRLABLIO
  1.  N LRAA
  1.  S LRAA=0
  1.  D LBLTYP^LRLABLD
  1.  ;
  1. T ; Print test label
  1.  D USE^%ZISUTL("LRHOME")
  1.  K DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  W !!,"Using label routine: ",LRLABEL,!
  1.  S DIR(0)="E"
  1.  S DIR("A",1)="Load and position label stock as appropriate for this printer."
  1.  S DIR("A")="Press return when ready"
  1.  D ^DIR
  1.  I Y'=1 D BD Q
  1.  ;
  1.  N I,N,PNM,SSN
  1.  N LRACC,LRBAR,LRBARID,LRCE,LRDAT,LRINFW,LRLLOC,LRPREF,LRAN,LRRB,LRTOP,LRTS,LRUID,LRURG,LRURG0,LRURGA,LRXL
  1.  NEW DOB,SEX            ; IHS/OIT/MKK - LR*5.2*1027
  1.  ;
  1.  ; Set up variables for test label
  1.  S PNM="TEST-LABEL-DO-NOT-USE",SSN="000-00-0000P",LRDAT="XX/XX/XX",LRLLOC="LAB",LRRB=1
  1.  S LRACC="SITE-TEST-LABEL",LRCE="9999999",LRPREF="SMALL "
  1.  S LRTOP="TEST-TUBE",LRTS(1)="Don't-use",LRTS(2)="this-label"
  1.  S LRINFW="Patient-info-field",(LRBARID,LRUID)="0000000000",LRAN="000",I=1,N=1,LRXL=0
  1.  S (LRURG,LRURG0)=1
  1.  S LRURGA=$$URGA^LRLABLD(LRURG0)
  1.  ; ----- BEGIN IHS/OIT/MKK MOD LR*5.2*1022
  1.  S LRAA=0
  1.  S LRAD=0
  1.  S PROV="TEST,PROV"
  1.  S DOB="XX/XX/XX"
  1.  S SEX="X"
  1.  ; ----- END IHS/OIT/MKK MOD LR*5.2*1022
  1.  ;
  1.  D LRBAR^LRLABLD
  1.  D USE^%ZISUTL("LRLABEL"),@LRLABEL
  1.  D USE^%ZISUTL("LRHOME")
  1.  ;
  1.  K DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  W !
  1.  S DIR(0)="YAO",DIR("A")="Label OK: ",DIR("B")="YES"
  1.  S DIR("?")="Enter 'YES' if label printed correctly, 'NO' if it did not."
  1.  D ^DIR
  1.  I $D(DIRUT) G BD
  1.  I Y=1 G K ;Note: this is not a kill, it is a GO to tag K (SAC catching these as a KILL)
  1.  ;
  1.  K DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  /*
  1.  W !
  1.  S DIR(0)="YAO",DIR("A")="Test printer again: ",DIR("B")="YES"
  1.  S DIR("?")="Enter 'YES' to test label printing, 'NO' to quit testing."
  1.  D ^DIR
  1.  I $D(DIRUT) G BD
  1.  */
  1.  S Y=0
  1.  I Y=1 G T
  1.  G K ;Note: this is not a kill, it is a GO to tag K (SAC catching these as a KILL)
  1.  ;
  1. BD ; Bad device - abort, timeout, unsuccessful selection
  1.  K LRLABLIO
  1.  D UNL69ERR^BLRAG05D
  1.  D ERR^BLRAGUT("BLRAGP5A: Print error")
  1. K ; Close devices
  1.  D CLOSE^%ZISUTL("LRLABEL")
  1.  D CLOSE^%ZISUTL("LRHOME")
  1.  Q
  1.  ;
  1. BLRTSTL(BLRTSTL) ;collect all tests for each specimen
  1.  ; .BLRTSTL   = (required) If all tests for a given specimen were not selected
  1.  ;                         and passed in, BLRTSTL will be returned with all tests
  1.  ;                         that are associated with the specimens represented in
  1.  ;                         this input.
  1.  ;                   The "TEST POINTERS" portion of this data comes
  1.  ;                   element 39 in the return from BLR ALL NON-ACCESSIONED.
  1.  ;                       List of test pointers with ICD9 pointers for each
  1.  ;                       test/procedure being accessioned separated by ^.
  1.  ;                       Each ^ piece is made up of these pipe pieces:
  1.  ;                       TEST POINTERS | [ICD9_IEN:ICD9_IEN:...] ^ ...
  1.  ;                        Test pointers = pointers to the LAB ORDER ENTRY
  1.  ;                        file 69 - DATE:SPECIMEN:TEST
  1.  ;                       ICD9_IEN - pointer to ICD DIAGNOSIS file 80 
  1.  ;
  1.  N BLRJ,BLRTN
  1.  N BLRTSTA    ;BLRTSTA(<DATE>,<SPECIMEN>,<TEST>)=<ICD9-POINTERS>
  1.  ;            ;BLRTSTA(<DATE>,<SPECIMEN>)=<ICD9-POINTERS>
  1.  N LRODT,LRSN,LRTN
  1.  S BLRTSTL=$G(BLRTSTL)
  1.  K BLRTSTA
  1.  ;put initial tests into the array
  1.  F BLRJ=1:1:$L(BLRTSTL,U) D
  1.  .S LRODT=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",1)
  1.  .S LRSN=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",2)
  1.  .S LRTN=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",3)
  1.  .S BLRTSTA(LRODT,LRSN,LRTN)=$P($P(BLRTSTL,U,BLRJ),"|",2)
  1.  .I $P($P(BLRTSTL,U,BLRJ),"|",2),$G(BLRTSTA(LRODT,LRSN))="" S BLRTSTA(LRODT,LRSN)=$P($P(BLRTSTL,U,BLRJ),"|",2)
  1.  ;add missing tests to the array
  1.  F BLRJ=1:1:$L(BLRTSTL,U) D
  1.  .S LRODT=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",1)
  1.  .S LRSN=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",2)
  1.  .S LRTN=0 F  S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:LRTN<1  D
  1.  ..Q:$D(BLRTSTA(LRODT,LRSN,LRTN))
  1.  ..S BLRTSTA(LRODT,LRSN,LRTN)=$G(BLRTSTA(LRODT,LRSN))
  1.  S BLRTSTL=""
  1.  S LRODT=0
  1.  F  S LRODT=$O(BLRTSTA(LRODT)) Q:LRODT'>0  D
  1.  .S LRSN=0 F  S LRSN=$O(BLRTSTA(LRODT,LRSN)) Q:LRSN'>0  D
  1.  ..S LRTN=0 F  S LRTN=$O(BLRTSTA(LRODT,LRSN,LRTN)) Q:LRTN'>0  D
  1.  ...S BLRICD=BLRTSTA(LRODT,LRSN,LRTN)
  1.  ...S:BLRICD="" BLRICD=$G(BLRTSTA(LRODT,LRSN))
  1.  ...S BLRTSTL=BLRTSTL_$S(BLRTSTL'="":"^",1:"")_LRODT_":"_LRSN_":"_LRTN_"|"_BLRICD
  1.  ;
  1.  K BLRTSTA
  1.  Q
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
  1. 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)
  1.  ;
  1.  ; Store ICD code(s) into Lab Order Entry (#69) file
  1.  S LROTIEN=LROT_","_LRSP_","_LRODT_","
  1.  F ICDCNT=1:1:$L(ICDSTR,":")  D
  1.  . S ICDIEN=$P(ICDSTR,":",ICDCNT)
  1.  . ;
  1.  . ; Skip if UNCODED DIAGNOSIS
  1.  . Q:$$GET1^DIQ(80,ICDIEN,.01)=".9999"!($$GET1^DIQ(80,ICDIEN,.01)="ZZZ.999")
  1.  . ;
  1.  . K ERRS,FDA
  1.  . S FDA(69.05,"?+1,"_LROTIEN,.01)=ICDIEN
  1.  . D UPDATE^DIE("S","FDA",,"ERRS")
  1.  . I $D(ERRS) D
  1.  .. S ^XTMP("BLRAG05",0)=$$HTFM^XLFDT(+$H+90)_U_$$DT^XLFDT_U_"GUI Accessioning ICD Code Error"
  1.  .. M ^XTMP("BLRAG05",$J,"STORF69D",$H,"FDA")=FDA
  1.  .. M ^XTMP("BLRAG05",$J,"STORF69D",$H,"ERRS")=ERRS
  1.  Q
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039