MDHL7K1 ; HOIFO/WAA-KenitDx Interface ; 06/08/00
;;1.0;CLINICAL PROCEDURES;**21**;Apr 01, 2004;Build 30
N TCNT,ICNT,LN
S (TCNT,ICNT,LN)=0
OBX ; Process OBX
N MDATT,PROC
D ATT^MDHL7U(DEVIEN,.MDATT) Q:MDATT<1
S PROC=0
F S PROC=$O(MDATT(PROC)) Q:PROC<1 D
. N PROCESS
. S PROCESS=$P(MDATT(PROC),";",5)
. I PROCESS="TEXT^MDHL7U2" D TEXT
. D @PROCESS
. Q
Q:'MDIEN
D REX^MDHL7U1(MDIEN)
D GENACK^MDHL7X
Q
TEXT ;This subroutine is to parse out the text
;
N CNT,P,LINE2,LINE,CNT2,CO,I,TEXT,DEL,TXT
S P="|",CNT=0,LINE2="",CNT2=0,CNT3=0
F S CNT=$O(^TMP($J,"MDHL7A",CNT)) Q:CNT<1 D
.S DEL="\.br\",LAST=""
.S LINE=^TMP($J,"MDHL7A",CNT)
.I $P(LINE,P,1)'="OBX" Q
.I $P(LINE,P,3)'="FT" Q
.S TEXT=$P(LINE,P,6)
.D LINE(TEXT,DEL)
.F S CNT3=$O(^TMP($J,"MDHL7A",CNT,CNT3)) Q:CNT3<1 D
.. S LINE=^TMP($J,"MDHL7A",CNT,CNT3)
.. S TEXT=LAST_LINE
.. D LINE(TEXT,DEL)
.. Q
.Q
Q
LINE(TEXT,DEL) ;
S CO=$L(TEXT,DEL)
I CO F I=1:1:CO D Q
. S TXT=$P(TEXT,DEL,I)
. D LG(TXT)
. ;D BUILD(TXT)
. Q
E D BUILD(TXT)
I $O(^TMP($J,"MDHL7A",CNT,CNT3))="" ; S LAST=$P(TXT,DEL,CO)
Q
;
;. S TXT=$P(TXT,DEL,CO)
;. I $L(TXT)>80 D LG(TXT) Q
;. Q
Q
LG(TXT) ; LARGE LINES
I $L(TXT)<80 D BUILD(TXT) Q
N SP,TTEXT,LAST,FIRST,TTTEXT,X
S TEXTTOT=TXT
S TXT80=$E(TXT,1,80),SP=$L(TXT80," ")
S TXT=$P(TXT80," ",1,$S(SP>1:SP-1,1:1))
D BUILD(TXT) S TXT=$E(TEXTTOT,($L(TXT)+2),$L(TEXTTOT))
I $L(TXT)>80 D LG(TXT)
Q
BUILD(TXT) ;
S LINE2="OBX||TX|||"
S $P(LINE2,P,6)=TXT
S CNT2=CNT2+1
S ^TMP($J,"MDHL7","TEXT",CNT2)=LINE2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDHL7K1 1591 printed Apr 09, 2024@20:48:27 Page 2
MDHL7K1 ; HOIFO/WAA-KenitDx Interface ; 06/08/00
+1 ;;1.0;CLINICAL PROCEDURES;**21**;Apr 01, 2004;Build 30
+2 NEW TCNT,ICNT,LN
+3 SET (TCNT,ICNT,LN)=0
OBX ; Process OBX
+1 NEW MDATT,PROC
+2 DO ATT^MDHL7U(DEVIEN,.MDATT)
if MDATT<1
QUIT
+3 SET PROC=0
+4 FOR
SET PROC=$ORDER(MDATT(PROC))
if PROC<1
QUIT
Begin DoDot:1
+5 NEW PROCESS
+6 SET PROCESS=$PIECE(MDATT(PROC),";",5)
+7 IF PROCESS="TEXT^MDHL7U2"
DO TEXT
+8 DO @PROCESS
+9 QUIT
End DoDot:1
+10 if 'MDIEN
QUIT
+11 DO REX^MDHL7U1(MDIEN)
+12 DO GENACK^MDHL7X
+13 QUIT
TEXT ;This subroutine is to parse out the text
+1 ;
+2 NEW CNT,P,LINE2,LINE,CNT2,CO,I,TEXT,DEL,TXT
+3 SET P="|"
SET CNT=0
SET LINE2=""
SET CNT2=0
SET CNT3=0
+4 FOR
SET CNT=$ORDER(^TMP($JOB,"MDHL7A",CNT))
if CNT<1
QUIT
Begin DoDot:1
+5 SET DEL="\.br\"
SET LAST=""
+6 SET LINE=^TMP($JOB,"MDHL7A",CNT)
+7 IF $PIECE(LINE,P,1)'="OBX"
QUIT
+8 IF $PIECE(LINE,P,3)'="FT"
QUIT
+9 SET TEXT=$PIECE(LINE,P,6)
+10 DO LINE(TEXT,DEL)
+11 FOR
SET CNT3=$ORDER(^TMP($JOB,"MDHL7A",CNT,CNT3))
if CNT3<1
QUIT
Begin DoDot:2
+12 SET LINE=^TMP($JOB,"MDHL7A",CNT,CNT3)
+13 SET TEXT=LAST_LINE
+14 DO LINE(TEXT,DEL)
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 QUIT
LINE(TEXT,DEL) ;
+1 SET CO=$LENGTH(TEXT,DEL)
+2 IF CO
FOR I=1:1:CO
Begin DoDot:1
+3 SET TXT=$PIECE(TEXT,DEL,I)
+4 DO LG(TXT)
+5 ;D BUILD(TXT)
+6 QUIT
End DoDot:1
QUIT
+7 IF '$TEST
DO BUILD(TXT)
+8 ; S LAST=$P(TXT,DEL,CO)
IF $ORDER(^TMP($JOB,"MDHL7A",CNT,CNT3))=""
+9 QUIT
+10 ;
+11 ;. S TXT=$P(TXT,DEL,CO)
+12 ;. I $L(TXT)>80 D LG(TXT) Q
+13 ;. Q
+14 QUIT
LG(TXT) ; LARGE LINES
+1 IF $LENGTH(TXT)<80
DO BUILD(TXT)
QUIT
+2 NEW SP,TTEXT,LAST,FIRST,TTTEXT,X
+3 SET TEXTTOT=TXT
+4 SET TXT80=$EXTRACT(TXT,1,80)
SET SP=$LENGTH(TXT80," ")
+5 SET TXT=$PIECE(TXT80," ",1,$SELECT(SP>1:SP-1,1:1))
+6 DO BUILD(TXT)
SET TXT=$EXTRACT(TEXTTOT,($LENGTH(TXT)+2),$LENGTH(TEXTTOT))
+7 IF $LENGTH(TXT)>80
DO LG(TXT)
+8 QUIT
BUILD(TXT) ;
+1 SET LINE2="OBX||TX|||"
+2 SET $PIECE(LINE2,P,6)=TXT
+3 SET CNT2=CNT2+1
+4 SET ^TMP($JOB,"MDHL7","TEXT",CNT2)=LINE2
+5 QUIT
