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