LA7VIN7C ;DALOI/JDB - Process ORU's OBX for Micro ;08/16/13 16:09
;;5.2;AUTOMATED LAB INSTRUMENTS;**74,80**;Sep 27, 1994;Build 19
;
; Continuation of LA7VIN7 and is only called from there.
; Process OBX segments for "MI" subscript tests.
Q
;
;
5 ; Process Virus (Subscript 17)
;
N X,SUB,ISQN2
I DDS<0!(DDP<1) D DDERR^LA7VIN7A Q
I LA7612<1 D Q ;
. ; Unknown entity in OBX-5
. N LA7VOBX5
. S LA7VOBX5=OBX5 ;needed for log
. S LA7VOBX5=$$UNESC^LA7VHLU3(LA7VOBX5,LA7FS_LA7ECH)
. D CREATE^LA7LOG(204)
. S LA7KILAH=1 S LA7QUIT=2
;
S ISQN2=0
I SUBID'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",17,SUBID)
I SUBID="" I $G(PSUBID)'="" S ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",17,PSUBID)
I 'ISQN2 D Q ;
. D SUBIDERR^LA7VIN71
;
S SUB="17,"_ISQN2_",0"
D LAH(SUB,DDP,LA7612) ; organism #61.2 IEN
S SUB="17,"_ISQN2_",.1"
D LAH(SUB,1,SUBID) ; isolate id
S SUB="17,"_ISQN2_",.01"
D LAH(SUB,1,LA7RLNC) ; LOINC IEN
D LAH(SUB,2,LA7RNLT) ; NLT code
D LAH(SUB,3,LA7SCT) ; SCT Code
S SUB="17,"_ISQN2_",0,.01,0"
D LAH(SUB,1,OBX11) ;
S SUB="17,"_ISQN2_",0,.01,1"
D LAH(SUB,1,LA74)
S X=$P(LA7RO,"^",3)
D LAH(SUB,2,X)
D NTE
Q
;
;
22(COM) ; Process TB Rpt Remark (Subscript 13)
; Input
; COM : <opt> The text to use for the remark (comment)
; : If empty OBX5 is used
;
N X,SUB,ISQN2,TEXT,TEXT2,MAXLEN
; Dont initialize COM
S SUB="13,0"
D LAH(SUB,1,LA74)
S X=$P(LA7RO,"^",3)
D LAH(SUB,2,X) ; resp obsv
D LAH(SUB,3,LA7RLNC) ; LOINC
D LAH(SUB,4,OBX11) ;obsv status
S ISQN2=$O(^LAH(LWL,1,LA7ISQN,"MI",13,"A"),-1)+1
; pull comment from COM or OBX5
S TEXT="OBX5"
I $D(COM)=1 S TEXT="COM"
I TEXT="OBX5" S TEXT2=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
I TEXT="COM" S TEXT2=$G(COM)
S MAXLEN=68 ; COMMENTS field size
S SUB="13,"_ISQN2_",0"
; insert separator line if needed
I ISQN2>1 D LAH(SUB,1," ") S ISQN2=ISQN2+1 S SUB="13,"_ISQN2_",0"
;
; if this an override insert Original Concept name
I $P(DSOBX3,"^",6) I $P(DSOBX3,"^",1)'=$P(DSOBX3,"^",6) D ;
. S X=$P(DSOBX3,"^",6) ;original concept
. S X=$G(^LAB(62.47,X,0))
. S X=$P(X,U,1)
. Q:X=""
. D LAH(SUB,1,"["_X_"]")
. S ISQN2=ISQN2+1 S SUB="13,"_ISQN2_",0"
;
; modify MAXLEN for prefixed Subid
I $L(TEXT2)'>MAXLEN D ;
. D LAH(SUB,1,TEXT2)
;
I $L(TEXT2)>MAXLEN D ;
. N I,Y,PASS
. S PASS=$L(TEXT2)\MAXLEN
. S:($L(TEXT2)#MAXLEN)>0 PASS=PASS+1
. F I=0:1:PASS-1 S Y=(I*MAXLEN)+1 D ;
. . D LAH(SUB,1,$E(TEXT2,Y,(Y+MAXLEN)-1))
. . S Y=Y+MAXLEN
. . S ISQN2=ISQN2+1
. . S SUB="13,"_ISQN2_",0"
. ;
D NTE^LA7VIN71(LA76247,ISQN)
Q
;
;
30(COM) ; Process Virology Rpt Remark (Subscript 18)
; Input
; COM : <opt> The text to use for the remark (comment)
; : If empty OBX5 is used
;
N X,SUB,ISQN2,TEXT,TEXT2,MAXLEN
; Dont initialize COM
S SUB="18,0"
D LAH(SUB,1,LA74)
S X=$P(LA7RO,"^",3)
D LAH(SUB,2,X) ; resp obsv
D LAH(SUB,3,LA7RLNC) ; LOINC
D LAH(SUB,4,OBX11) ;obsv status
S ISQN2=$O(^LAH(LWL,1,LA7ISQN,"MI",18,"A"),-1)+1
; pull comment from COM or OBX5
S TEXT="OBX5"
I $D(COM)=1 S TEXT="COM"
I TEXT="OBX5" S TEXT2=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
I TEXT="COM" S TEXT2=$G(COM)
S MAXLEN=68 ; COMMENTS field size
S SUB="18,"_ISQN2_",0"
; insert separator line if needed
I ISQN2>1 D LAH(SUB,1," ") S ISQN2=ISQN2+1 S SUB="18,"_ISQN2_",0"
;
; if this an override insert Original Concept name
I $P(DSOBX3,"^",6) I $P(DSOBX3,"^",1)'=$P(DSOBX3,"^",6) D ;
. S X=$P(DSOBX3,"^",6) ;original concept
. S X=$G(^LAB(62.47,X,0))
. S X=$P(X,U,1)
. Q:X=""
. D LAH(SUB,1,"["_X_"]")
. S ISQN2=ISQN2+1 S SUB="13,"_ISQN2_",0"
;
; modify MAXLEN for prefixed Subid
I $L(TEXT2)'>MAXLEN D ;
. D LAH(SUB,1,TEXT2)
I $L(TEXT2)>MAXLEN D ;
. N I,Y,PASS
. S PASS=$L(TEXT2)\MAXLEN
. S:($L(TEXT2)#MAXLEN)>0 PASS=PASS+1
. F I=0:1:PASS-1 S Y=(I*MAXLEN)+1 D ;
. . D LAH(SUB,1,$E(TEXT2,Y,(Y+MAXLEN)-1))
. . S Y=Y+MAXLEN
. . S ISQN2=ISQN2+1
. . S SUB="18,"_ISQN2_",0"
. ;
D NTE^LA7VIN71(LA76247,ISQN)
Q
;
;
48 ; Process Sterility Results (Subscript 31)
;
N LRX,SUB,ISQN2
S ISQN2=$O(^LAH(LWL,1,LA7ISQN,"MI",31,"A"),-1)+1
S SUB="31,"_ISQN2_",0"
S LRX=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
D ;
. N LRZ,LAMSG
. D CHK^DIE(63.292,.01,"",LRX,.LRZ,"LAMSG")
. I $G(LRZ)'="^" S LRX=LRZ
;
D LAH(SUB,1,LRX)
;
D ADDINFO(31,ISQN2) ;
;
D NTE^LA7VIN71(LA76247,ISQN)
Q
;
;
NODE(LA76247,COM) ; Process series of free-text multiples.
;
; Handles the following 62.47 concepts and the corresponding free-text multiple in Microbiology (MI) subscript
; Sequence Concept Field Subscript
;
; 40 MYCOLOGY SMEAR/PREP (#19.6) MYCOLOGY SMEAR/PREP 15
; 41 PARASITOLOGY SMEAR PREP (#15.51) PARASITOLOGY SMEAR/PREP 24
; 42 BACTERIOLOGY SMEAR PREP (#11.7) BACTERIOLOGY SMEAR/PREP 25
; 43 BACTERIOLOGY TEST (#1.5) BACTERIOLOGY TEST(S) 26
; 44 PARASITE TEST (#16.4) PARASITE TEST(S) 27
; 45 MYCOLOGY TEST (#20.4) MYCOLOGY TEST(S) 28
; 46 TB TEST (#26.4) TB TEST(S) 29
; 47 VIROLOGY TEST (#36.4) VIROLOGY TESTS 30
;
; The following are currently processed from NTE segments - See LA7VIN2A (NTE/MISPC)
; 86 MI PRELIMINARY BACT COMMENT (#1) PRELIMINARY BACT COMMENT 19
; 87 MI PRELIMINARY VIROLOGY COMMENT (#36.5) PRELIMINARY VIROLOGY COMMENT 20
; 88 MI PRELIMINARY PARASITE COMMENT (#16.5) PRELIMINARY PARASITE COMMENT 21
; 89 MI PRELIMINARY MYCOLOGY COMMENT (#20.5) PRELIMINARY MYCOLOGY COMMENT 22
; 90 MI PRELIMINARY TB COMMENT (#26.5) PRELIMINARY TB COMMENT 23
;
; Input
; LA76247 : ien of related concept in file #62.47
; COM : <opt> The text to use for the remark (comment)
; : If empty OBX5 is used
;
; Don't initialize COM
;
N ISQN2,MAXLEN,SUB,SUBROOT,TEXT,TEXT2,X
;
; Determine subscript based on 62.47 concept number.
I LA76247<48 S SUBROOT=$P("15^24^25^26^27^28^29^30","^",LA76247-39)
E S SUBROOT=$P("19^20^21^22^23","^",LA76247-85)
;
S ISQN2=$O(^LAH(LWL,1,LA7ISQN,"MI",SUBROOT,"A"),-1)+1
S SUB=SUBROOT_","_ISQN2_",0"
;
; pull comment from COM or OBX5
I $G(COM)="" S TEXT="OBX5",TEXT2=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
E S TEXT="COM",TEXT2=COM
S MAXLEN=68 ; free-text field size
;
; insert separator line if needed
I ISQN2>1 D
. D LAH(SUB,1," ")
. D ADDINFO(SUBROOT,ISQN2)
. S ISQN2=ISQN2+1,SUB=SUBROOT_","_ISQN2_",0"
;
; if this an override insert Original Concept name
I $P(DSOBX3,"^",6),$P(DSOBX3,"^",1)'=$P(DSOBX3,"^",6) D
. S X=$P(DSOBX3,"^",6) ;original concept
. S X=$G(^LAB(62.47,X,0))
. S X=$P(X,U,1)
. Q:X=""
. D LAH(SUB,1,"["_X_"]")
. D ADDINFO(SUBROOT,ISQN2)
. S ISQN2=ISQN2+1,SUB=SUBROOT_","_ISQN2_",0"
;
; modify MAXLEN for prefixed Subid
I $L(TEXT2)'>MAXLEN D LAH(SUB,1,TEXT2),ADDINFO(SUBROOT,ISQN2)
;
I $L(TEXT2)>MAXLEN D
. N LA7I,LA7Y,PASS
. S PASS=$L(TEXT2)\MAXLEN
. S:($L(TEXT2)#MAXLEN)>0 PASS=PASS+1
. F LA7I=0:1:PASS-1 D
. . S LA7Y=(LA7I*MAXLEN)+1
. . D LAH(SUB,1,$E(TEXT2,LA7Y,(LA7Y+MAXLEN)-1))
. . D ADDINFO(SUBROOT,ISQN2)
. . S LA7Y=LA7Y+MAXLEN
. . S ISQN2=ISQN2+1,SUB=SUBROOT_","_ISQN2_",0"
;
D NTE^LA7VIN71(LA76247,ISQN)
;
Q
;
;
LAH(LASUB,LAP,LAVAL) ;
; Convenience method
D LAH^LAGEN(+$G(LWL),+$G(LA7ISQN),"MI",LASUB,LAP,LAVAL)
Q
;
;
NTE ;
; Convenience method
D NTE^LA7VIN71(LA76247,ISQN2)
Q
;
;
ADDINFO(SUBSCR,ISQN2) ;
; Add result info (lab, person, status, etc.) to comment nodes.
; Used for adding info to each comment line (0,0 node)
; Inputs
; SUBSCR: The LAH subscript (eg 25 for Concept 42)
; ISQN2: The comment sequence number.
N SUB,X,Y
S SUBSCR=$G(SUBSCR)
S ISQN2=$G(ISQN2)
S SUB=SUBSCR_","_ISQN2_",0,0"
D LAH(SUB,1,LA74)
S X=$P(LA7RO,"^",3)
D LAH(SUB,2,X) ; resp obsv
D LAH(SUB,3,LA7RLNC) ; LOINC
D LAH(SUB,4,OBX11) ;obsv status
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VIN7C 8341 printed Apr 09, 2024@20:45:57 Page 2
LA7VIN7C ;DALOI/JDB - Process ORU's OBX for Micro ;08/16/13 16:09
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74,80**;Sep 27, 1994;Build 19
+2 ;
+3 ; Continuation of LA7VIN7 and is only called from there.
+4 ; Process OBX segments for "MI" subscript tests.
+5 QUIT
+6 ;
+7 ;
5 ; Process Virus (Subscript 17)
+1 ;
+2 NEW X,SUB,ISQN2
+3 IF DDS<0!(DDP<1)
DO DDERR^LA7VIN7A
QUIT
+4 ;
IF LA7612<1
Begin DoDot:1
+5 ; Unknown entity in OBX-5
+6 NEW LA7VOBX5
+7 ;needed for log
SET LA7VOBX5=OBX5
+8 SET LA7VOBX5=$$UNESC^LA7VHLU3(LA7VOBX5,LA7FS_LA7ECH)
+9 DO CREATE^LA7LOG(204)
+10 SET LA7KILAH=1
SET LA7QUIT=2
End DoDot:1
QUIT
+11 ;
+12 SET ISQN2=0
+13 IF SUBID'=""
SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",17,SUBID)
+14 IF SUBID=""
IF $GET(PSUBID)'=""
SET ISQN2=$$SUBID^LAGEN(LWL,LA7ISQN,"MI",17,PSUBID)
+15 ;
IF 'ISQN2
Begin DoDot:1
+16 DO SUBIDERR^LA7VIN71
End DoDot:1
QUIT
+17 ;
+18 SET SUB="17,"_ISQN2_",0"
+19 ; organism #61.2 IEN
DO LAH(SUB,DDP,LA7612)
+20 SET SUB="17,"_ISQN2_",.1"
+21 ; isolate id
DO LAH(SUB,1,SUBID)
+22 SET SUB="17,"_ISQN2_",.01"
+23 ; LOINC IEN
DO LAH(SUB,1,LA7RLNC)
+24 ; NLT code
DO LAH(SUB,2,LA7RNLT)
+25 ; SCT Code
DO LAH(SUB,3,LA7SCT)
+26 SET SUB="17,"_ISQN2_",0,.01,0"
+27 ;
DO LAH(SUB,1,OBX11)
+28 SET SUB="17,"_ISQN2_",0,.01,1"
+29 DO LAH(SUB,1,LA74)
+30 SET X=$PIECE(LA7RO,"^",3)
+31 DO LAH(SUB,2,X)
+32 DO NTE
+33 QUIT
+34 ;
+35 ;
22(COM) ; Process TB Rpt Remark (Subscript 13)
+1 ; Input
+2 ; COM : <opt> The text to use for the remark (comment)
+3 ; : If empty OBX5 is used
+4 ;
+5 NEW X,SUB,ISQN2,TEXT,TEXT2,MAXLEN
+6 ; Dont initialize COM
+7 SET SUB="13,0"
+8 DO LAH(SUB,1,LA74)
+9 SET X=$PIECE(LA7RO,"^",3)
+10 ; resp obsv
DO LAH(SUB,2,X)
+11 ; LOINC
DO LAH(SUB,3,LA7RLNC)
+12 ;obsv status
DO LAH(SUB,4,OBX11)
+13 SET ISQN2=$ORDER(^LAH(LWL,1,LA7ISQN,"MI",13,"A"),-1)+1
+14 ; pull comment from COM or OBX5
+15 SET TEXT="OBX5"
+16 IF $DATA(COM)=1
SET TEXT="COM"
+17 IF TEXT="OBX5"
SET TEXT2=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
+18 IF TEXT="COM"
SET TEXT2=$GET(COM)
+19 ; COMMENTS field size
SET MAXLEN=68
+20 SET SUB="13,"_ISQN2_",0"
+21 ; insert separator line if needed
+22 IF ISQN2>1
DO LAH(SUB,1," ")
SET ISQN2=ISQN2+1
SET SUB="13,"_ISQN2_",0"
+23 ;
+24 ; if this an override insert Original Concept name
+25 ;
IF $PIECE(DSOBX3,"^",6)
IF $PIECE(DSOBX3,"^",1)'=$PIECE(DSOBX3,"^",6)
Begin DoDot:1
+26 ;original concept
SET X=$PIECE(DSOBX3,"^",6)
+27 SET X=$GET(^LAB(62.47,X,0))
+28 SET X=$PIECE(X,U,1)
+29 if X=""
QUIT
+30 DO LAH(SUB,1,"["_X_"]")
+31 SET ISQN2=ISQN2+1
SET SUB="13,"_ISQN2_",0"
End DoDot:1
+32 ;
+33 ; modify MAXLEN for prefixed Subid
+34 ;
IF $LENGTH(TEXT2)'>MAXLEN
Begin DoDot:1
+35 DO LAH(SUB,1,TEXT2)
End DoDot:1
+36 ;
+37 ;
IF $LENGTH(TEXT2)>MAXLEN
Begin DoDot:1
+38 NEW I,Y,PASS
+39 SET PASS=$LENGTH(TEXT2)\MAXLEN
+40 if ($LENGTH(TEXT2)#MAXLEN)>0
SET PASS=PASS+1
+41 ;
FOR I=0:1:PASS-1
SET Y=(I*MAXLEN)+1
Begin DoDot:2
+42 DO LAH(SUB,1,$EXTRACT(TEXT2,Y,(Y+MAXLEN)-1))
+43 SET Y=Y+MAXLEN
+44 SET ISQN2=ISQN2+1
+45 SET SUB="13,"_ISQN2_",0"
End DoDot:2
+46 ;
End DoDot:1
+47 DO NTE^LA7VIN71(LA76247,ISQN)
+48 QUIT
+49 ;
+50 ;
30(COM) ; Process Virology Rpt Remark (Subscript 18)
+1 ; Input
+2 ; COM : <opt> The text to use for the remark (comment)
+3 ; : If empty OBX5 is used
+4 ;
+5 NEW X,SUB,ISQN2,TEXT,TEXT2,MAXLEN
+6 ; Dont initialize COM
+7 SET SUB="18,0"
+8 DO LAH(SUB,1,LA74)
+9 SET X=$PIECE(LA7RO,"^",3)
+10 ; resp obsv
DO LAH(SUB,2,X)
+11 ; LOINC
DO LAH(SUB,3,LA7RLNC)
+12 ;obsv status
DO LAH(SUB,4,OBX11)
+13 SET ISQN2=$ORDER(^LAH(LWL,1,LA7ISQN,"MI",18,"A"),-1)+1
+14 ; pull comment from COM or OBX5
+15 SET TEXT="OBX5"
+16 IF $DATA(COM)=1
SET TEXT="COM"
+17 IF TEXT="OBX5"
SET TEXT2=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
+18 IF TEXT="COM"
SET TEXT2=$GET(COM)
+19 ; COMMENTS field size
SET MAXLEN=68
+20 SET SUB="18,"_ISQN2_",0"
+21 ; insert separator line if needed
+22 IF ISQN2>1
DO LAH(SUB,1," ")
SET ISQN2=ISQN2+1
SET SUB="18,"_ISQN2_",0"
+23 ;
+24 ; if this an override insert Original Concept name
+25 ;
IF $PIECE(DSOBX3,"^",6)
IF $PIECE(DSOBX3,"^",1)'=$PIECE(DSOBX3,"^",6)
Begin DoDot:1
+26 ;original concept
SET X=$PIECE(DSOBX3,"^",6)
+27 SET X=$GET(^LAB(62.47,X,0))
+28 SET X=$PIECE(X,U,1)
+29 if X=""
QUIT
+30 DO LAH(SUB,1,"["_X_"]")
+31 SET ISQN2=ISQN2+1
SET SUB="13,"_ISQN2_",0"
End DoDot:1
+32 ;
+33 ; modify MAXLEN for prefixed Subid
+34 ;
IF $LENGTH(TEXT2)'>MAXLEN
Begin DoDot:1
+35 DO LAH(SUB,1,TEXT2)
End DoDot:1
+36 ;
IF $LENGTH(TEXT2)>MAXLEN
Begin DoDot:1
+37 NEW I,Y,PASS
+38 SET PASS=$LENGTH(TEXT2)\MAXLEN
+39 if ($LENGTH(TEXT2)#MAXLEN)>0
SET PASS=PASS+1
+40 ;
FOR I=0:1:PASS-1
SET Y=(I*MAXLEN)+1
Begin DoDot:2
+41 DO LAH(SUB,1,$EXTRACT(TEXT2,Y,(Y+MAXLEN)-1))
+42 SET Y=Y+MAXLEN
+43 SET ISQN2=ISQN2+1
+44 SET SUB="18,"_ISQN2_",0"
End DoDot:2
+45 ;
End DoDot:1
+46 DO NTE^LA7VIN71(LA76247,ISQN)
+47 QUIT
+48 ;
+49 ;
48 ; Process Sterility Results (Subscript 31)
+1 ;
+2 NEW LRX,SUB,ISQN2
+3 SET ISQN2=$ORDER(^LAH(LWL,1,LA7ISQN,"MI",31,"A"),-1)+1
+4 SET SUB="31,"_ISQN2_",0"
+5 SET LRX=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
+6 ;
Begin DoDot:1
+7 NEW LRZ,LAMSG
+8 DO CHK^DIE(63.292,.01,"",LRX,.LRZ,"LAMSG")
+9 IF $GET(LRZ)'="^"
SET LRX=LRZ
End DoDot:1
+10 ;
+11 DO LAH(SUB,1,LRX)
+12 ;
+13 ;
DO ADDINFO(31,ISQN2)
+14 ;
+15 DO NTE^LA7VIN71(LA76247,ISQN)
+16 QUIT
+17 ;
+18 ;
NODE(LA76247,COM) ; Process series of free-text multiples.
+1 ;
+2 ; Handles the following 62.47 concepts and the corresponding free-text multiple in Microbiology (MI) subscript
+3 ; Sequence Concept Field Subscript
+4 ;
+5 ; 40 MYCOLOGY SMEAR/PREP (#19.6) MYCOLOGY SMEAR/PREP 15
+6 ; 41 PARASITOLOGY SMEAR PREP (#15.51) PARASITOLOGY SMEAR/PREP 24
+7 ; 42 BACTERIOLOGY SMEAR PREP (#11.7) BACTERIOLOGY SMEAR/PREP 25
+8 ; 43 BACTERIOLOGY TEST (#1.5) BACTERIOLOGY TEST(S) 26
+9 ; 44 PARASITE TEST (#16.4) PARASITE TEST(S) 27
+10 ; 45 MYCOLOGY TEST (#20.4) MYCOLOGY TEST(S) 28
+11 ; 46 TB TEST (#26.4) TB TEST(S) 29
+12 ; 47 VIROLOGY TEST (#36.4) VIROLOGY TESTS 30
+13 ;
+14 ; The following are currently processed from NTE segments - See LA7VIN2A (NTE/MISPC)
+15 ; 86 MI PRELIMINARY BACT COMMENT (#1) PRELIMINARY BACT COMMENT 19
+16 ; 87 MI PRELIMINARY VIROLOGY COMMENT (#36.5) PRELIMINARY VIROLOGY COMMENT 20
+17 ; 88 MI PRELIMINARY PARASITE COMMENT (#16.5) PRELIMINARY PARASITE COMMENT 21
+18 ; 89 MI PRELIMINARY MYCOLOGY COMMENT (#20.5) PRELIMINARY MYCOLOGY COMMENT 22
+19 ; 90 MI PRELIMINARY TB COMMENT (#26.5) PRELIMINARY TB COMMENT 23
+20 ;
+21 ; Input
+22 ; LA76247 : ien of related concept in file #62.47
+23 ; COM : <opt> The text to use for the remark (comment)
+24 ; : If empty OBX5 is used
+25 ;
+26 ; Don't initialize COM
+27 ;
+28 NEW ISQN2,MAXLEN,SUB,SUBROOT,TEXT,TEXT2,X
+29 ;
+30 ; Determine subscript based on 62.47 concept number.
+31 IF LA76247<48
SET SUBROOT=$PIECE("15^24^25^26^27^28^29^30","^",LA76247-39)
+32 IF '$TEST
SET SUBROOT=$PIECE("19^20^21^22^23","^",LA76247-85)
+33 ;
+34 SET ISQN2=$ORDER(^LAH(LWL,1,LA7ISQN,"MI",SUBROOT,"A"),-1)+1
+35 SET SUB=SUBROOT_","_ISQN2_",0"
+36 ;
+37 ; pull comment from COM or OBX5
+38 IF $GET(COM)=""
SET TEXT="OBX5"
SET TEXT2=$$UNESC^LA7VHLU3(OBX5,LA7FS_LA7ECH)
+39 IF '$TEST
SET TEXT="COM"
SET TEXT2=COM
+40 ; free-text field size
SET MAXLEN=68
+41 ;
+42 ; insert separator line if needed
+43 IF ISQN2>1
Begin DoDot:1
+44 DO LAH(SUB,1," ")
+45 DO ADDINFO(SUBROOT,ISQN2)
+46 SET ISQN2=ISQN2+1
SET SUB=SUBROOT_","_ISQN2_",0"
End DoDot:1
+47 ;
+48 ; if this an override insert Original Concept name
+49 IF $PIECE(DSOBX3,"^",6)
IF $PIECE(DSOBX3,"^",1)'=$PIECE(DSOBX3,"^",6)
Begin DoDot:1
+50 ;original concept
SET X=$PIECE(DSOBX3,"^",6)
+51 SET X=$GET(^LAB(62.47,X,0))
+52 SET X=$PIECE(X,U,1)
+53 if X=""
QUIT
+54 DO LAH(SUB,1,"["_X_"]")
+55 DO ADDINFO(SUBROOT,ISQN2)
+56 SET ISQN2=ISQN2+1
SET SUB=SUBROOT_","_ISQN2_",0"
End DoDot:1
+57 ;
+58 ; modify MAXLEN for prefixed Subid
+59 IF $LENGTH(TEXT2)'>MAXLEN
DO LAH(SUB,1,TEXT2)
DO ADDINFO(SUBROOT,ISQN2)
+60 ;
+61 IF $LENGTH(TEXT2)>MAXLEN
Begin DoDot:1
+62 NEW LA7I,LA7Y,PASS
+63 SET PASS=$LENGTH(TEXT2)\MAXLEN
+64 if ($LENGTH(TEXT2)#MAXLEN)>0
SET PASS=PASS+1
+65 FOR LA7I=0:1:PASS-1
Begin DoDot:2
+66 SET LA7Y=(LA7I*MAXLEN)+1
+67 DO LAH(SUB,1,$EXTRACT(TEXT2,LA7Y,(LA7Y+MAXLEN)-1))
+68 DO ADDINFO(SUBROOT,ISQN2)
+69 SET LA7Y=LA7Y+MAXLEN
+70 SET ISQN2=ISQN2+1
SET SUB=SUBROOT_","_ISQN2_",0"
End DoDot:2
End DoDot:1
+71 ;
+72 DO NTE^LA7VIN71(LA76247,ISQN)
+73 ;
+74 QUIT
+75 ;
+76 ;
LAH(LASUB,LAP,LAVAL) ;
+1 ; Convenience method
+2 DO LAH^LAGEN(+$GET(LWL),+$GET(LA7ISQN),"MI",LASUB,LAP,LAVAL)
+3 QUIT
+4 ;
+5 ;
NTE ;
+1 ; Convenience method
+2 DO NTE^LA7VIN71(LA76247,ISQN2)
+3 QUIT
+4 ;
+5 ;
ADDINFO(SUBSCR,ISQN2) ;
+1 ; Add result info (lab, person, status, etc.) to comment nodes.
+2 ; Used for adding info to each comment line (0,0 node)
+3 ; Inputs
+4 ; SUBSCR: The LAH subscript (eg 25 for Concept 42)
+5 ; ISQN2: The comment sequence number.
+6 NEW SUB,X,Y
+7 SET SUBSCR=$GET(SUBSCR)
+8 SET ISQN2=$GET(ISQN2)
+9 SET SUB=SUBSCR_","_ISQN2_",0,0"
+10 DO LAH(SUB,1,LA74)
+11 SET X=$PIECE(LA7RO,"^",3)
+12 ; resp obsv
DO LAH(SUB,2,X)
+13 ; LOINC
DO LAH(SUB,3,LA7RLNC)
+14 ;obsv status
DO LAH(SUB,4,OBX11)
+15 QUIT
