BLRAG05G ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ;03 MAY 2013 1200;SAT
;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
;
Q
;
;RPC to return Ask at Order Entry questions for the lab tests that go with the passed in Lab Order Entry file pointers.
; BLRAG05G AOE
;Input:
; BLRTSTL = (required) The "TEST POINTERS" portion of this data comes
; element 39 in the return from BLR ALL NON-ACCESSIONED.
; List of test pointers for each
; test/procedure being accessioned separated by ^.
; Each ^ piece is made up of these pipe pieces:
; TEST POINTERS | [ICD9_LIST_(not_used)] ^ ...
; Test pointers = pointers to the LAB ORDER ENTRY
; file 69 - DATE:SPECIMEN:TEST
; Note that these are the same pointers that are passed into BLR ACCESSION
;Output: BLRAOE=Count of items in array
; BLRAOE(<test ien>,<counter>)=Question prompt^Result Code^Lab Name
AOE(BLRAOE,BLRTSTL) ;EP-
N BLRDT,BLRJ,BLRSP,BLRTST
N CNT,IEN,X
D ^XBKVAR ;setup minimum KERNEL variables
S X="ERROR^BLRAG05G",@^%ZOSF("TRAP") ;setup error trap
S BLRAOE=0
S CNT=0
I $G(BLRTSTL)'="" D
.F BLRJ=1:1:$L(BLRTSTL,U) D
..S BLRDT=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",1)
..S BLRSP=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",2)
..S BLRTST=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",3)
..S BLRTST60=$P($G(^LRO(69,+$G(BLRDT),1,+$G(BLRSP),2,+$G(BLRTST),0)),U,1) ;get test
..D GETPMT(BLRTST60)
S BLRAOE=CNT
Q
;
; Add prompts to return array for a given test
GETPMT(TST) ;EP-
N RL,RC,RI,N0,PC,TI,SC,LN
S RL=$P($G(^BLRSITE(DUZ(2),"RL")),U)
Q:'RL
S RI=$O(^BLRRL("ALP",TST,RL,0))
Q:'RI
S LN=$P($G(^LAB(60,+$G(TST),0)),U,1)
S RC=0 F S RC=$O(^BLRRL(RL,1,RI,1,RC)) Q:'RC D
.S PC=$G(^BLRRL(RL,1,RI,1,RC,0))
.S TP=$O(^BLRRL("BRES",PC,RL,0))
.Q:'TP
.S N0=^BLRRL(RL,1,TP,0)
.S TI=$P(N0,U,7)
.S SC=$P(N0,U,4)
.S CNT=CNT+1
.S BLRAOE(TST,CNT)=TI_U_SC_U_LN
Q
;
ERROR ;
D ENTRYAUD^BLRUTIL("ERROR^BLRAG05G 0.0") ; Store Error data
NEW ERRORMSG
S ERRORMSG="$"_"Z"_"E=""ERROR^BLRAG05G""" ; BYPASS SAC Checker
S @ERRORMSG D ^%ZTER
D ERR("RPMS Error")
Q
;
ERR(BLRERR) ;Error processing
; BLRERR = Error text OR error code
; BLRAGI = pointer into return global array
I +BLRERR S BLRERR=BLRERR+134234112 ;vbObjectError
S BLRAOE=-1
Q
BLRAG05G ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ;03 MAY 2013 1200;SAT
+1 ;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
+2 ;
+3 QUIT
+4 ;
+5 ;RPC to return Ask at Order Entry questions for the lab tests that go with the passed in Lab Order Entry file pointers.
+6 ; BLRAG05G AOE
+7 ;Input:
+8 ; BLRTSTL = (required) The "TEST POINTERS" portion of this data comes
+9 ; element 39 in the return from BLR ALL NON-ACCESSIONED.
+10 ; List of test pointers for each
+11 ; test/procedure being accessioned separated by ^.
+12 ; Each ^ piece is made up of these pipe pieces:
+13 ; TEST POINTERS | [ICD9_LIST_(not_used)] ^ ...
+14 ; Test pointers = pointers to the LAB ORDER ENTRY
+15 ; file 69 - DATE:SPECIMEN:TEST
+16 ; Note that these are the same pointers that are passed into BLR ACCESSION
+17 ;Output: BLRAOE=Count of items in array
+18 ; BLRAOE(<test ien>,<counter>)=Question prompt^Result Code^Lab Name
AOE(BLRAOE,BLRTSTL) ;EP-
+1 NEW BLRDT,BLRJ,BLRSP,BLRTST
+2 NEW CNT,IEN,X
+3 ;setup minimum KERNEL variables
DO ^XBKVAR
+4 ;setup error trap
SET X="ERROR^BLRAG05G"
SET @^%ZOSF("TRAP")
+5 SET BLRAOE=0
+6 SET CNT=0
+7 IF $GET(BLRTSTL)'=""
Begin DoDot:1
+8 FOR BLRJ=1:1:$LENGTH(BLRTSTL,U)
Begin DoDot:2
+9 SET BLRDT=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",1)
+10 SET BLRSP=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",2)
+11 SET BLRTST=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",3)
+12 ;get test
SET BLRTST60=$PIECE($GET(^LRO(69,+$GET(BLRDT),1,+$GET(BLRSP),2,+$GET(BLRTST),0)),U,1)
+13 DO GETPMT(BLRTST60)
End DoDot:2
End DoDot:1
+14 SET BLRAOE=CNT
+15 QUIT
+16 ;
+17 ; Add prompts to return array for a given test
GETPMT(TST) ;EP-
+1 NEW RL,RC,RI,N0,PC,TI,SC,LN
+2 SET RL=$PIECE($GET(^BLRSITE(DUZ(2),"RL")),U)
+3 IF 'RL
QUIT
+4 SET RI=$ORDER(^BLRRL("ALP",TST,RL,0))
+5 IF 'RI
QUIT
+6 SET LN=$PIECE($GET(^LAB(60,+$GET(TST),0)),U,1)
+7 SET RC=0
FOR
SET RC=$ORDER(^BLRRL(RL,1,RI,1,RC))
IF 'RC
QUIT
Begin DoDot:1
+8 SET PC=$GET(^BLRRL(RL,1,RI,1,RC,0))
+9 SET TP=$ORDER(^BLRRL("BRES",PC,RL,0))
+10 IF 'TP
QUIT
+11 SET N0=^BLRRL(RL,1,TP,0)
+12 SET TI=$PIECE(N0,U,7)
+13 SET SC=$PIECE(N0,U,4)
+14 SET CNT=CNT+1
+15 SET BLRAOE(TST,CNT)=TI_U_SC_U_LN
End DoDot:1
+16 QUIT
+17 ;
ERROR ;
+1 ; Store Error data
DO ENTRYAUD^BLRUTIL("ERROR^BLRAG05G 0.0")
+2 NEW ERRORMSG
+3 ; BYPASS SAC Checker
SET ERRORMSG="$"_"Z"_"E=""ERROR^BLRAG05G"""
+4 SET @ERRORMSG
DO ^%ZTER
+5 DO ERR("RPMS Error")
+6 QUIT
+7 ;
ERR(BLRERR) ;Error processing
+1 ; BLRERR = Error text OR error code
+2 ; BLRAGI = pointer into return global array
+3 ;vbObjectError
IF +BLRERR
SET BLRERR=BLRERR+134234112
+4 SET BLRAOE=-1
+5 QUIT
