LA7VIN6 ;DALOI/JMC - PROCESS ORU OBX FOR AP ;11/18/11 14:01
;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
;
; Continuation of LA7VIN1 and is only called from there.
; It is called to process OBX segments for AP subscript tests.
;
; ZEXCEPT is used to identify variables which are external to a specific TAG
; used in conjunction with Eclipse M-editor.
;
Q
;
;
PROCESS ; File AP ^LAH for a given concept (LA76247)
;
;ZEXCEPT: DSOBX5,LA74,LA76247,LA76248,LA7CS,LA7ECH,LA7FS,LAPSUBID,OBX3,OBX4,OBX5
;
N SUBID,PSUBID,LAX,CNCPTOR
S SUBID=$G(OBX4)
S SUBID=$$UNESC^LA7VHLU3(SUBID,LA7FS_LA7ECH)
S SUBID=$$TRIM^XLFSTR(SUBID)
S SUBID=$$MAKEISO^LRVRMI1(LA74,SUBID)
S PSUBID=$$TRIM^XLFSTR($G(LAPSUBID))
S PSUBID=$$MAKEISO^LRVRMI1(LA74,PSUBID)
I SUBID="" S SUBID=PSUBID
;
; Need to override the concept?
S CNCPTOR=0
I OBX5[LA7CS,+DSOBX5=-1 D
. S LAX=$P(DSOBX5,"^",5)
. I LAX,LAX'=LA76247 S CNCPTOR=1,LA76247=LAX
;
; Override LOINC codes to handle fact that some generic codes can be applied to more than one storage location.
;
; Check if VA SP Frozen Section and use VA NLT to find concept - SP FROZEN SECTION and SP MICROSCOPIC DESCRIPTION use same LOINC code.
I LA76247=56,$G(OBX3(6))="99VA64",$P(OBX3(4),".")="88569" D
. N X
. S X=$$HL2LAH^LA7VHLU6(OBX3(4),OBX3(5),OBX3(6),OBX3(8),LA76248,"SP")
. I X>0 S LA76247=+X
;
D SET(LA76247)
Q
;
;
SET(R6247) ;
;
;ZEXCEPT: LA74,LA7ECH,LA7FS,LA7ISQN,LA7KILAH,LA7QUIT,LA7RLNC,LA7RNLT,LA7RO,LA7SS,LA7VTYP,LWL,OBX,OBX3,OBX5,OBX11
;
N I,ISQN2,ISQN3,NODE,REC,RSZ,SUB,VAL,X,Y
;
D SETSUB
;
; If SUB=-1 then something went wrong
; Error: No filing method found for OBX3
I SUB<0 D Q
. N LA7VOBX3
. S LA7VOBX3=OBX3
. D CREATE^LA7LOG(202)
. S LA7KILAH=1,LA7QUIT=2
;
;
; Need to develop logic to handle specimen multiple - JMC/13 Nov 2009.
I SUB?1(1"50") Q
;
S NODE=SUB
; WP subscript
K ISQN3
S (REC,ISQN2)=+$O(^LAH(LWL,1,LA7ISQN,LA7SS,SUB,"A"),-1)
;
; These reports store one more level in (need ISQN2 in NODE)
I R6247?1(1"59",1"62",1"69",1"78") D
. I ISQN2<1 S ISQN2=1
. S NODE=NODE_","_ISQN2
. S ISQN3=+$O(^LAH(LWL,1,LA7ISQN,LA7SS,SUB,ISQN2,1,"A"),-1)
;
S NODE=NODE_",0"
D LAH(NODE,1,LA74)
S X=$P(LA7RO,"^",3)
D LAH(NODE,2,X)
D LAH(NODE,3,LA7RLNC)
D LAH(NODE,4,LA7RNLT)
D LAH(NODE,5,OBX11)
;
; Suppl Rpt Release Date from OBR-22
I R6247?1(1"59",1"62",1"69",1"78") D LAH(NODE,6,$G(LA7RSDT))
;
; file WP nodes
I LA7VTYP="FT" D
. K X,Y,VAL
. S X(1)=OBX5
. D UNESCFT^LA7VHLU3(.X,LA7FS_LA7ECH,.Y)
. S X=""
. F S X=$O(Y(X)) Q:'X D ;
. . D REPT2ARR^LA7VHLU7(Y(X,0),LA7FS_LA7ECH,.VAL)
. ;
;
I LA7VTYP'="FT" D
. K VAL
. D REPT2ARR^LA7VHLU7(OBX5,LA7FS_LA7ECH,.VAL)
; resize array so it fits on global node
K RSZ
D RSZARR(.VAL,.RSZ,245)
K VAL
S I=0
I $D(ISQN3) S REC=ISQN3
F S I=$O(RSZ(I)) Q:'I D
. S REC=REC+1
. ; need to reset NODE depending on levels needed
. S NODE=SUB_","_REC_",0"
. I "^59^62^69^78^"[("^"_R6247_"^") S NODE=SUB_","_ISQN2_",1,"_REC_",0"
. D LAH(NODE,-1,RSZ(I))
;
K RSZ
D NTE
Q
;
;
LAH(LANODE,LAP,LAVAL) ; Convenience method
;
Q:LAVAL=""
D LAH^LAGEN(+$G(LWL),+$G(LA7ISQN),LA7SS,LANODE,LAP,LAVAL)
Q
;
;
NTE ; Convenience method
;
;ZEXCEPT: ISQN2,R6247
D NTE^LA7VIN71(R6247,ISQN2)
Q
;
;
RSZARR(IN,OUT,LEN) ; Resizes the values of an array
; ie resize string lengths to fit on global nodes
N I,II,J,X
S LEN=+$G(LEN)
Q:LEN<1
S (I,II)=0
F S I=$O(IN(I)) Q:'I D
. I $L(IN(I))'>LEN S II=II+1 S OUT(II)=IN(I) Q
. S X=IN(I)
. S II=$O(OUT("A"),-1)
. F Q:X="" S II=II+1 S OUT(II)=$E(X,1,LEN) S X=$E(X,LEN+1,$L(X))
Q
;
;
SETSUB ; Set SUB to subcript for this concept.
;
;ZEXCEPT: R6247,SUB
S SUB=-1
;
; SP subscript
I R6247=50 S SUB=.1 Q
I R6247=51 S SUB=.2 Q
I R6247=52 S SUB=.3 Q
I R6247=53 S SUB=.4 Q
I R6247=54 S SUB=.5 Q
I R6247=55 S SUB=1 Q
I R6247=56 S SUB=1.1 Q
I R6247=57 S SUB=1.3 Q
I R6247=58 S SUB=1.4 Q
I R6247=59 S SUB=1.2 Q
I R6247=62 S SUB=1.2 Q
I R6247=80 S SUB=99 Q
;
; CY subscript
I R6247=63 S SUB=.2 Q
I R6247=64 S SUB=1 Q
I R6247=65 S SUB=1.1 Q
I R6247=66 S SUB=.4 Q
I R6247=67 S SUB=.3 Q
I R6247=68 S SUB=.5 Q
I R6247=69 S SUB=1.2 Q
I R6247=81 S SUB=99 Q
I R6247=83 S SUB=1.4 Q
;
; EM subscript
I R6247=71 S SUB=.2 Q
I R6247=72 S SUB=1 Q
I R6247=73 S SUB=1.1 Q
I R6247=74 S SUB=.4 Q
I R6247=75 S SUB=.5 Q
I R6247=76 S SUB=.3 Q
I R6247=78 S SUB=1.2 Q
I R6247=82 S SUB=99 Q
I R6247=84 S SUB=1.4 Q
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VIN6 4641 printed Sep 11, 2024@02:00:39 Page 2
LA7VIN6 ;DALOI/JMC - PROCESS ORU OBX FOR AP ;11/18/11 14:01
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
+2 ;
+3 ; Continuation of LA7VIN1 and is only called from there.
+4 ; It is called to process OBX segments for AP subscript tests.
+5 ;
+6 ; ZEXCEPT is used to identify variables which are external to a specific TAG
+7 ; used in conjunction with Eclipse M-editor.
+8 ;
+9 QUIT
+10 ;
+11 ;
PROCESS ; File AP ^LAH for a given concept (LA76247)
+1 ;
+2 ;ZEXCEPT: DSOBX5,LA74,LA76247,LA76248,LA7CS,LA7ECH,LA7FS,LAPSUBID,OBX3,OBX4,OBX5
+3 ;
+4 NEW SUBID,PSUBID,LAX,CNCPTOR
+5 SET SUBID=$GET(OBX4)
+6 SET SUBID=$$UNESC^LA7VHLU3(SUBID,LA7FS_LA7ECH)
+7 SET SUBID=$$TRIM^XLFSTR(SUBID)
+8 SET SUBID=$$MAKEISO^LRVRMI1(LA74,SUBID)
+9 SET PSUBID=$$TRIM^XLFSTR($GET(LAPSUBID))
+10 SET PSUBID=$$MAKEISO^LRVRMI1(LA74,PSUBID)
+11 IF SUBID=""
SET SUBID=PSUBID
+12 ;
+13 ; Need to override the concept?
+14 SET CNCPTOR=0
+15 IF OBX5[LA7CS
IF +DSOBX5=-1
Begin DoDot:1
+16 SET LAX=$PIECE(DSOBX5,"^",5)
+17 IF LAX
IF LAX'=LA76247
SET CNCPTOR=1
SET LA76247=LAX
End DoDot:1
+18 ;
+19 ; Override LOINC codes to handle fact that some generic codes can be applied to more than one storage location.
+20 ;
+21 ; Check if VA SP Frozen Section and use VA NLT to find concept - SP FROZEN SECTION and SP MICROSCOPIC DESCRIPTION use same LOINC code.
+22 IF LA76247=56
IF $GET(OBX3(6))="99VA64"
IF $PIECE(OBX3(4),".")="88569"
Begin DoDot:1
+23 NEW X
+24 SET X=$$HL2LAH^LA7VHLU6(OBX3(4),OBX3(5),OBX3(6),OBX3(8),LA76248,"SP")
+25 IF X>0
SET LA76247=+X
End DoDot:1
+26 ;
+27 DO SET(LA76247)
+28 QUIT
+29 ;
+30 ;
SET(R6247) ;
+1 ;
+2 ;ZEXCEPT: LA74,LA7ECH,LA7FS,LA7ISQN,LA7KILAH,LA7QUIT,LA7RLNC,LA7RNLT,LA7RO,LA7SS,LA7VTYP,LWL,OBX,OBX3,OBX5,OBX11
+3 ;
+4 NEW I,ISQN2,ISQN3,NODE,REC,RSZ,SUB,VAL,X,Y
+5 ;
+6 DO SETSUB
+7 ;
+8 ; If SUB=-1 then something went wrong
+9 ; Error: No filing method found for OBX3
+10 IF SUB<0
Begin DoDot:1
+11 NEW LA7VOBX3
+12 SET LA7VOBX3=OBX3
+13 DO CREATE^LA7LOG(202)
+14 SET LA7KILAH=1
SET LA7QUIT=2
End DoDot:1
QUIT
+15 ;
+16 ;
+17 ; Need to develop logic to handle specimen multiple - JMC/13 Nov 2009.
+18 IF SUB?1(1"50")
QUIT
+19 ;
+20 SET NODE=SUB
+21 ; WP subscript
+22 KILL ISQN3
+23 SET (REC,ISQN2)=+$ORDER(^LAH(LWL,1,LA7ISQN,LA7SS,SUB,"A"),-1)
+24 ;
+25 ; These reports store one more level in (need ISQN2 in NODE)
+26 IF R6247?1(1"59",1"62",1"69",1"78")
Begin DoDot:1
+27 IF ISQN2<1
SET ISQN2=1
+28 SET NODE=NODE_","_ISQN2
+29 SET ISQN3=+$ORDER(^LAH(LWL,1,LA7ISQN,LA7SS,SUB,ISQN2,1,"A"),-1)
End DoDot:1
+30 ;
+31 SET NODE=NODE_",0"
+32 DO LAH(NODE,1,LA74)
+33 SET X=$PIECE(LA7RO,"^",3)
+34 DO LAH(NODE,2,X)
+35 DO LAH(NODE,3,LA7RLNC)
+36 DO LAH(NODE,4,LA7RNLT)
+37 DO LAH(NODE,5,OBX11)
+38 ;
+39 ; Suppl Rpt Release Date from OBR-22
+40 IF R6247?1(1"59",1"62",1"69",1"78")
DO LAH(NODE,6,$GET(LA7RSDT))
+41 ;
+42 ; file WP nodes
+43 IF LA7VTYP="FT"
Begin DoDot:1
+44 KILL X,Y,VAL
+45 SET X(1)=OBX5
+46 DO UNESCFT^LA7VHLU3(.X,LA7FS_LA7ECH,.Y)
+47 SET X=""
+48 ;
FOR
SET X=$ORDER(Y(X))
if 'X
QUIT
Begin DoDot:2
+49 DO REPT2ARR^LA7VHLU7(Y(X,0),LA7FS_LA7ECH,.VAL)
End DoDot:2
+50 ;
End DoDot:1
+51 ;
+52 IF LA7VTYP'="FT"
Begin DoDot:1
+53 KILL VAL
+54 DO REPT2ARR^LA7VHLU7(OBX5,LA7FS_LA7ECH,.VAL)
End DoDot:1
+55 ; resize array so it fits on global node
+56 KILL RSZ
+57 DO RSZARR(.VAL,.RSZ,245)
+58 KILL VAL
+59 SET I=0
+60 IF $DATA(ISQN3)
SET REC=ISQN3
+61 FOR
SET I=$ORDER(RSZ(I))
if 'I
QUIT
Begin DoDot:1
+62 SET REC=REC+1
+63 ; need to reset NODE depending on levels needed
+64 SET NODE=SUB_","_REC_",0"
+65 IF "^59^62^69^78^"[("^"_R6247_"^")
SET NODE=SUB_","_ISQN2_",1,"_REC_",0"
+66 DO LAH(NODE,-1,RSZ(I))
End DoDot:1
+67 ;
+68 KILL RSZ
+69 DO NTE
+70 QUIT
+71 ;
+72 ;
LAH(LANODE,LAP,LAVAL) ; Convenience method
+1 ;
+2 if LAVAL=""
QUIT
+3 DO LAH^LAGEN(+$GET(LWL),+$GET(LA7ISQN),LA7SS,LANODE,LAP,LAVAL)
+4 QUIT
+5 ;
+6 ;
NTE ; Convenience method
+1 ;
+2 ;ZEXCEPT: ISQN2,R6247
+3 DO NTE^LA7VIN71(R6247,ISQN2)
+4 QUIT
+5 ;
+6 ;
RSZARR(IN,OUT,LEN) ; Resizes the values of an array
+1 ; ie resize string lengths to fit on global nodes
+2 NEW I,II,J,X
+3 SET LEN=+$GET(LEN)
+4 if LEN<1
QUIT
+5 SET (I,II)=0
+6 FOR
SET I=$ORDER(IN(I))
if 'I
QUIT
Begin DoDot:1
+7 IF $LENGTH(IN(I))'>LEN
SET II=II+1
SET OUT(II)=IN(I)
QUIT
+8 SET X=IN(I)
+9 SET II=$ORDER(OUT("A"),-1)
+10 FOR
if X=""
QUIT
SET II=II+1
SET OUT(II)=$EXTRACT(X,1,LEN)
SET X=$EXTRACT(X,LEN+1,$LENGTH(X))
End DoDot:1
+11 QUIT
+12 ;
+13 ;
SETSUB ; Set SUB to subcript for this concept.
+1 ;
+2 ;ZEXCEPT: R6247,SUB
+3 SET SUB=-1
+4 ;
+5 ; SP subscript
+6 IF R6247=50
SET SUB=.1
QUIT
+7 IF R6247=51
SET SUB=.2
QUIT
+8 IF R6247=52
SET SUB=.3
QUIT
+9 IF R6247=53
SET SUB=.4
QUIT
+10 IF R6247=54
SET SUB=.5
QUIT
+11 IF R6247=55
SET SUB=1
QUIT
+12 IF R6247=56
SET SUB=1.1
QUIT
+13 IF R6247=57
SET SUB=1.3
QUIT
+14 IF R6247=58
SET SUB=1.4
QUIT
+15 IF R6247=59
SET SUB=1.2
QUIT
+16 IF R6247=62
SET SUB=1.2
QUIT
+17 IF R6247=80
SET SUB=99
QUIT
+18 ;
+19 ; CY subscript
+20 IF R6247=63
SET SUB=.2
QUIT
+21 IF R6247=64
SET SUB=1
QUIT
+22 IF R6247=65
SET SUB=1.1
QUIT
+23 IF R6247=66
SET SUB=.4
QUIT
+24 IF R6247=67
SET SUB=.3
QUIT
+25 IF R6247=68
SET SUB=.5
QUIT
+26 IF R6247=69
SET SUB=1.2
QUIT
+27 IF R6247=81
SET SUB=99
QUIT
+28 IF R6247=83
SET SUB=1.4
QUIT
+29 ;
+30 ; EM subscript
+31 IF R6247=71
SET SUB=.2
QUIT
+32 IF R6247=72
SET SUB=1
QUIT
+33 IF R6247=73
SET SUB=1.1
QUIT
+34 IF R6247=74
SET SUB=.4
QUIT
+35 IF R6247=75
SET SUB=.5
QUIT
+36 IF R6247=76
SET SUB=.3
QUIT
+37 IF R6247=78
SET SUB=1.2
QUIT
+38 IF R6247=82
SET SUB=99
QUIT
+39 IF R6247=84
SET SUB=1.4
QUIT
+40 ;
+41 QUIT
