MDAR7M ; HOIFO/NCA - Get Text Impression ;2/27/09 12:38
;;1.0;Clinical Procedures;**21,24**;Apr 01, 2004;Build 8
; Integration Agreement:
; IA # 2263 [Supported] XPAR Calls
; 10103 [Supported] XLFDT Calls
; 10104 [Supported] Calls to XLFSTR
;
GETTXT(MDTXR,RECID) ; Get text impression
N CCNT,CNT,CODE,ICNT,LAST,LL,LNE,MDAR,MDC,MDCH,MDFG,MDHLST,MDHS,MDK,MDLAB,MDMUSE,MDNAD,MDOBR,MDPENT,MDPN,MDRESL,MDSY,MDX,SEG,TXT,UNITS,VAL,X,XN
S (ICNT,MDFG,MDPENT)=0,(MDOBR,MDPN)=""
Q:'+$G(RECID)
S MDRESL=+$P($G(^MDD(703.1,+RECID,0)),"^",6)
S MDSY=+$P($G(^MDD(703.1,+RECID,0)),"^",5) Q:'MDSY
D GETLST^XPAR(.MDHLST,"SYS","MD GET HIGH VOLUME")
F MDK=0:0 S MDK=$O(MDHLST(MDK)) Q:MDK<1 I $P($G(MDHLST(MDK)),"^")=+$P(^MDD(702,+MDSY,0),U,4) S MDFG=$P($G(MDHLST(MDK)),"^",2) Q
S ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)="** DOCUMENT IN VISTA IMAGING **"
S ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)="SEE FULL REPORT IN VISTA IMAGING",ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)=""
I '$P(MDFG,";",2) S ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)="SIGNATURE NOT REQUIRED"
I '$P(MDFG,";",2) S ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)="SEE SIGNATURE IN VISTA IMAGING",ICNT=ICNT+1
S MDTXR("TEXT",ICNT,0)=""
Q:'+MDFG
Q:+$P($G(^MDS(702.01,+$P(^MDD(702,+MDSY,0),U,4),0)),"^",6)=2
Q:+$P($G(^MDS(702.01,+$P(^MDD(702,+MDSY,0),U,4),0)),"^",11)=2
S (MDLAB,MDNAD,MDMUSE,MDPENT,MDHS)=0
I +$$GET^XPAR("SYS","MD NOT ADMN CLOSE MUSE NOTE",1) S MDNAD=1
S:$$UP^XLFSTR($$GET1^DIQ(702,+MDSY_",",".11","E"))["PENTAX" MDPENT=1
S:$$UP^XLFSTR($$GET1^DIQ(702,+MDSY_",",".11","E"))["MUSE" MDMUSE=1
S:$$UP^XLFSTR($$GET1^DIQ(702,+MDSY_",",".11","E"))["HS-VAS" MDHS=1
S:$$UP^XLFSTR($$GET1^DIQ(702,+MDSY_",",".11","E"))["LABORIE" MDLAB=1
Q:'MDRESL
Q:'$D(^TMP($J,"MDHL7A"))
S ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)="** ("_$$GET1^DIQ(702,+MDSY_",",".11","E")_") AUTO-INSTRUMENT DIAGNOSIS **",ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)=""
S LAST=$O(^TMP($J,"MDHL7A",""),-1)
F MDK=1:1:LAST S XN=$G(^TMP($J,"MDHL7A",MDK)),TXT="" D
.I $P(XN,"|",1)="OBR" S SEG=XN S (MDOBR,TXT)=$$OBR(SEG) I TXT'="" D
..S MDPN=$P(TXT,";",5) I MDPN["99999" S MDPN=$P(MDPN,"99999",2)
..I MDPN'="" S ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)="Procedure: "_MDPN
..S LNE=""
..I $P(TXT,";",2)'="" S ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)="",ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)="Release Status: "_$P(TXT,";",2)
..I $P(TXT,";")'="" S LNE="Date Verified: "_$P(TXT,";"),ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)=LNE
..I $P(TXT,";",3)'=""&(+MDMUSE) S LNE="Interpreter: "_$P(TXT,";",3),ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)=LNE
..I $P(TXT,";",3)'=""&(+MDMUSE)&(+MDNAD) S MDTXR(1202)=$P(TXT,";",6),MDTXR(1204)=$P(TXT,";",6),MDTXR(1302)=$P(TXT,";",6)
..I $P(MDOBR,";",4)="C" S MDTXR("TEXT",0)="AMENDMENT"
..S ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)="" Q
.I $P(XN,"|",1)="OBX" S SEG=XN Q:$P(SEG,"|",3)="ST"&($P(SEG,"|",6)["^") S TXT=$$OBX(SEG) D
..I $P(SEG,"|",3)'="ST" S ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)=TXT Q
..I +MDHS&($P(SEG,"|",3)="TX")&(TXT="") S TXT=$P(SEG,"|",5)
..S CODE=$P(SEG,"|",4),VAL=$P(SEG,"|",6),UNITS=$P(SEG,"|",7),CCNT=$L(VAL),CNT=0
..I CODE["^" S CODE=$S(+$P(CODE,"^",1):+$P(CODE,"^",1)_" "_$P(CODE,"^",2),1:$P(CODE,"^",2))
..Q:CODE=""!(VAL="")
..Q:VAL["\\"
..I $L(VAL)<50 S LNE=$E(CODE_":"_$J("",30),1,30)_VAL S:UNITS'="" LNE=$E(LNE_$J("",10),1,38)_UNITS S ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)=LNE Q
..E K MDAR S ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)=$E(CODE_":"_$J("",30),1,30) D WP(.MDAR,VAL,CNT) F MDC=0:0 S MDC=$O(MDAR(MDC)) Q:MDC<1 S ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)=$G(MDAR(MDC))
..S ICNT=ICNT+1,MDTXR("TEXT",ICNT,0)="" Q
.Q
Q
OBR(SEGM) ; Get OBR
N EXAM,LINE,X,XNM
S EXAM=$P($P(SEGM,"|",5),"^",1) S:EXAM="" EXAM=99999
S EXAM=EXAM_" "_$P($P(SEGM,"|",5),"^",2)
; S SGET=Date verified;Release status;Interpreter;Result status;Interpreter ien
S X=$P(SEGM,"|",23) I X>0 S SGET=$$HL7TFM^XLFDT(X)_";"_"Released Off-Line Verified" ;
S X=$P($P(SEGM,"|",33),"^",1)
S XNM=$$GET1^DIQ(200,X,.01,"I")
I +X,XNM'="" S $P(SGET,";",3)=XNM,$P(SGET,";",6)=+X
S X=$P($G(SGET),";")
I X'="" S $P(SGET,";")=$$FMTE^XLFDT(X)
S:$P(SEGM,"|",26)="F" $P(SGET,";",4)="F"
S:$P(SEGM,"|",26)="C" $P(SGET,";",4)="C"
S $P(SGET,";",5)=EXAM
Q SGET
OBX(SEGM) ; Process OBX
N CODE,LINE,STYP,VAL,X1
S X1=$G(SEGM)
S STYP=$P(X1,"|",3) Q:STYP="ST" ""
S CODE=$P(X1,"|",4),VAL=$P(X1,"|",6),UNITS=$P(X1,"|",7) I CODE["^" S CODE=$S(+$P(CODE,"^",1):+$P(CODE,"^",1)_" "_$P(CODE,"^",2),1:$P(CODE,"^",2))
I CODE=""&(VAL="") Q ""
I STYP="CE" S VAL=$P(VAL,"^",2)
Q:VAL["\\" ""
I +MDLAB&(STYP="TX") S LINE=$E(CODE_":"_$J("",30),1,30)_VAL I UNITS'="" S LINE=$E(LINE_$J("",10),1,38)_UNITS Q LINE
I STYP="TX"!(STYP="FT") Q VAL
I STYP="CE" S LINE=$E(CODE_":"_$J("",30),1,30)_VAL Q LINE
I STYP="XCN" S VAL=$P(VAL,"^",3)_" "_$P(VAL,"^",4)_" "_$P(VAL,"^",2)_" "_$P(VAL,"^",7),LINE=$E(CODE_":"_$J("",30),1,30)_VAL Q LINE
I STYP="DT"!(STYP="TS") S VAL=$$HL7TFM^XLFDT(VAL),VAL=$$FMTE^XLFDT(VAL) S LINE=$E(CODE_":"_$J("",30),1,30)_VAL Q LINE
S LINE=$E(CODE_":"_$J("",30),1,30)_VAL
I UNITS'="" S LINE=$E(LINE_$J("",10),1,38)_UNITS
Q LINE
WP(MDGAR,LTXT,MDJ) ; Process Word Process lines
N LOP
LOOP I $L(LTXT)<70 S MDJ=MDJ+1,MDGAR(MDJ)=$J("",10)_LTXT Q
F LOP=70:-1:1 Q:$E(LTXT,LOP)?1P
S MDJ=MDJ+1,MDGAR(MDJ)=$J("",10)_$E(LTXT,1,LOP-1)
S LTXT=$E(LTXT,LOP+1,999) G LOOP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDAR7M 5339 printed Nov 22, 2024@16:52:21 Page 2
MDAR7M ; HOIFO/NCA - Get Text Impression ;2/27/09 12:38
+1 ;;1.0;Clinical Procedures;**21,24**;Apr 01, 2004;Build 8
+2 ; Integration Agreement:
+3 ; IA # 2263 [Supported] XPAR Calls
+4 ; 10103 [Supported] XLFDT Calls
+5 ; 10104 [Supported] Calls to XLFSTR
+6 ;
GETTXT(MDTXR,RECID) ; Get text impression
+1 NEW CCNT,CNT,CODE,ICNT,LAST,LL,LNE,MDAR,MDC,MDCH,MDFG,MDHLST,MDHS,MDK,MDLAB,MDMUSE,MDNAD,MDOBR,MDPENT,MDPN,MDRESL,MDSY,MDX,SEG,TXT,UNITS,VAL,X,XN
+2 SET (ICNT,MDFG,MDPENT)=0
SET (MDOBR,MDPN)=""
+3 if '+$GET(RECID)
QUIT
+4 SET MDRESL=+$PIECE($GET(^MDD(703.1,+RECID,0)),"^",6)
+5 SET MDSY=+$PIECE($GET(^MDD(703.1,+RECID,0)),"^",5)
if 'MDSY
QUIT
+6 DO GETLST^XPAR(.MDHLST,"SYS","MD GET HIGH VOLUME")
+7 FOR MDK=0:0
SET MDK=$ORDER(MDHLST(MDK))
if MDK<1
QUIT
IF $PIECE($GET(MDHLST(MDK)),"^")=+$PIECE(^MDD(702,+MDSY,0),U,4)
SET MDFG=$PIECE($GET(MDHLST(MDK)),"^",2)
QUIT
+8 SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)="** DOCUMENT IN VISTA IMAGING **"
+9 SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)="SEE FULL REPORT IN VISTA IMAGING"
SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)=""
+10 IF '$PIECE(MDFG,";",2)
SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)="SIGNATURE NOT REQUIRED"
+11 IF '$PIECE(MDFG,";",2)
SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)="SEE SIGNATURE IN VISTA IMAGING"
SET ICNT=ICNT+1
+12 SET MDTXR("TEXT",ICNT,0)=""
+13 if '+MDFG
QUIT
+14 if +$PIECE($GET(^MDS(702.01,+$PIECE(^MDD(702,+MDSY,0),U,4),0)),"^",6)=2
QUIT
+15 if +$PIECE($GET(^MDS(702.01,+$PIECE(^MDD(702,+MDSY,0),U,4),0)),"^",11)=2
QUIT
+16 SET (MDLAB,MDNAD,MDMUSE,MDPENT,MDHS)=0
+17 IF +$$GET^XPAR("SYS","MD NOT ADMN CLOSE MUSE NOTE",1)
SET MDNAD=1
+18 if $$UP^XLFSTR($$GET1^DIQ(702,+MDSY_",",".11","E"))["PENTAX"
SET MDPENT=1
+19 if $$UP^XLFSTR($$GET1^DIQ(702,+MDSY_",",".11","E"))["MUSE"
SET MDMUSE=1
+20 if $$UP^XLFSTR($$GET1^DIQ(702,+MDSY_",",".11","E"))["HS-VAS"
SET MDHS=1
+21 if $$UP^XLFSTR($$GET1^DIQ(702,+MDSY_",",".11","E"))["LABORIE"
SET MDLAB=1
+22 if 'MDRESL
QUIT
+23 if '$DATA(^TMP($JOB,"MDHL7A"))
QUIT
+24 SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)="** ("_$$GET1^DIQ(702,+MDSY_",",".11","E")_") AUTO-INSTRUMENT DIAGNOSIS **"
SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)=""
+25 SET LAST=$ORDER(^TMP($JOB,"MDHL7A",""),-1)
+26 FOR MDK=1:1:LAST
SET XN=$GET(^TMP($JOB,"MDHL7A",MDK))
SET TXT=""
Begin DoDot:1
+27 IF $PIECE(XN,"|",1)="OBR"
SET SEG=XN
SET (MDOBR,TXT)=$$OBR(SEG)
IF TXT'=""
Begin DoDot:2
+28 SET MDPN=$PIECE(TXT,";",5)
IF MDPN["99999"
SET MDPN=$PIECE(MDPN,"99999",2)
+29 IF MDPN'=""
SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)="Procedure: "_MDPN
+30 SET LNE=""
+31 IF $PIECE(TXT,";",2)'=""
SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)=""
SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)="Release Status: "_$PIECE(TXT,";",2)
+32 IF $PIECE(TXT,";")'=""
SET LNE="Date Verified: "_$PIECE(TXT,";")
SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)=LNE
+33 IF $PIECE(TXT,";",3)'=""&(+MDMUSE)
SET LNE="Interpreter: "_$PIECE(TXT,";",3)
SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)=LNE
+34 IF $PIECE(TXT,";",3)'=""&(+MDMUSE)&(+MDNAD)
SET MDTXR(1202)=$PIECE(TXT,";",6)
SET MDTXR(1204)=$PIECE(TXT,";",6)
SET MDTXR(1302)=$PIECE(TXT,";",6)
+35 IF $PIECE(MDOBR,";",4)="C"
SET MDTXR("TEXT",0)="AMENDMENT"
+36 SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)=""
QUIT
End DoDot:2
+37 IF $PIECE(XN,"|",1)="OBX"
SET SEG=XN
if $PIECE(SEG,"|",3)="ST"&($PIECE(SEG,"|",6)["^")
QUIT
SET TXT=$$OBX(SEG)
Begin DoDot:2
+38 IF $PIECE(SEG,"|",3)'="ST"
SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)=TXT
QUIT
+39 IF +MDHS&($PIECE(SEG,"|",3)="TX")&(TXT="")
SET TXT=$PIECE(SEG,"|",5)
+40 SET CODE=$PIECE(SEG,"|",4)
SET VAL=$PIECE(SEG,"|",6)
SET UNITS=$PIECE(SEG,"|",7)
SET CCNT=$LENGTH(VAL)
SET CNT=0
+41 IF CODE["^"
SET CODE=$SELECT(+$PIECE(CODE,"^",1):+$PIECE(CODE,"^",1)_" "_$PIECE(CODE,"^",2),1:$PIECE(CODE,"^",2))
+42 if CODE=""!(VAL="")
QUIT
+43 if VAL["\\"
QUIT
+44 IF $LENGTH(VAL)<50
SET LNE=$EXTRACT(CODE_":"_$JUSTIFY("",30),1,30)_VAL
if UNITS'=""
SET LNE=$EXTRACT(LNE_$JUSTIFY("",10),1,38)_UNITS
SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)=LNE
QUIT
+45 IF '$TEST
KILL MDAR
SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)=$EXTRACT(CODE_":"_$JUSTIFY("",30),1,30)
DO WP(.MDAR,VAL,CNT)
FOR MDC=0:0
SET MDC=$ORDER(MDAR(MDC))
if MDC<1
QUIT
SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)=$GET(MDAR(MDC))
+46 SET ICNT=ICNT+1
SET MDTXR("TEXT",ICNT,0)=""
QUIT
End DoDot:2
+47 QUIT
End DoDot:1
+48 QUIT
OBR(SEGM) ; Get OBR
+1 NEW EXAM,LINE,X,XNM
+2 SET EXAM=$PIECE($PIECE(SEGM,"|",5),"^",1)
if EXAM=""
SET EXAM=99999
+3 SET EXAM=EXAM_" "_$PIECE($PIECE(SEGM,"|",5),"^",2)
+4 ; S SGET=Date verified;Release status;Interpreter;Result status;Interpreter ien
+5 ;
SET X=$PIECE(SEGM,"|",23)
IF X>0
SET SGET=$$HL7TFM^XLFDT(X)_";"_"Released Off-Line Verified"
+6 SET X=$PIECE($PIECE(SEGM,"|",33),"^",1)
+7 SET XNM=$$GET1^DIQ(200,X,.01,"I")
+8 IF +X
IF XNM'=""
SET $PIECE(SGET,";",3)=XNM
SET $PIECE(SGET,";",6)=+X
+9 SET X=$PIECE($GET(SGET),";")
+10 IF X'=""
SET $PIECE(SGET,";")=$$FMTE^XLFDT(X)
+11 if $PIECE(SEGM,"|",26)="F"
SET $PIECE(SGET,";",4)="F"
+12 if $PIECE(SEGM,"|",26)="C"
SET $PIECE(SGET,";",4)="C"
+13 SET $PIECE(SGET,";",5)=EXAM
+14 QUIT SGET
OBX(SEGM) ; Process OBX
+1 NEW CODE,LINE,STYP,VAL,X1
+2 SET X1=$GET(SEGM)
+3 SET STYP=$PIECE(X1,"|",3)
if STYP="ST"
QUIT ""
+4 SET CODE=$PIECE(X1,"|",4)
SET VAL=$PIECE(X1,"|",6)
SET UNITS=$PIECE(X1,"|",7)
IF CODE["^"
SET CODE=$SELECT(+$PIECE(CODE,"^",1):+$PIECE(CODE,"^",1)_" "_$PIECE(CODE,"^",2),1:$PIECE(CODE,"^",2))
+5 IF CODE=""&(VAL="")
QUIT ""
+6 IF STYP="CE"
SET VAL=$PIECE(VAL,"^",2)
+7 if VAL["\\"
QUIT ""
+8 IF +MDLAB&(STYP="TX")
SET LINE=$EXTRACT(CODE_":"_$JUSTIFY("",30),1,30)_VAL
IF UNITS'=""
SET LINE=$EXTRACT(LINE_$JUSTIFY("",10),1,38)_UNITS
QUIT LINE
+9 IF STYP="TX"!(STYP="FT")
QUIT VAL
+10 IF STYP="CE"
SET LINE=$EXTRACT(CODE_":"_$JUSTIFY("",30),1,30)_VAL
QUIT LINE
+11 IF STYP="XCN"
SET VAL=$PIECE(VAL,"^",3)_" "_$PIECE(VAL,"^",4)_" "_$PIECE(VAL,"^",2)_" "_$PIECE(VAL,"^",7)
SET LINE=$EXTRACT(CODE_":"_$JUSTIFY("",30),1,30)_VAL
QUIT LINE
+12 IF STYP="DT"!(STYP="TS")
SET VAL=$$HL7TFM^XLFDT(VAL)
SET VAL=$$FMTE^XLFDT(VAL)
SET LINE=$EXTRACT(CODE_":"_$JUSTIFY("",30),1,30)_VAL
QUIT LINE
+13 SET LINE=$EXTRACT(CODE_":"_$JUSTIFY("",30),1,30)_VAL
+14 IF UNITS'=""
SET LINE=$EXTRACT(LINE_$JUSTIFY("",10),1,38)_UNITS
+15 QUIT LINE
WP(MDGAR,LTXT,MDJ) ; Process Word Process lines
+1 NEW LOP
LOOP IF $LENGTH(LTXT)<70
SET MDJ=MDJ+1
SET MDGAR(MDJ)=$JUSTIFY("",10)_LTXT
QUIT
+1 FOR LOP=70:-1:1
if $EXTRACT(LTXT,LOP)?1P
QUIT
+2 SET MDJ=MDJ+1
SET MDGAR(MDJ)=$JUSTIFY("",10)_$EXTRACT(LTXT,1,LOP-1)
+3 SET LTXT=$EXTRACT(LTXT,LOP+1,999)
GOTO LOOP
