MCAR7M1 ; HIRMFO/REL-Muse EKG ;6/7/00 10:11
;;2.3;Medicine;**24**;09/13/1996
S EXAM=$P($P(SEG("OBR"),"|",5),"^",1) S:EXAM="" EXAM=99999
S X=$T(@EXAM),FIL=$P(X,";",4),SUB=$P(X,";",5) I FIL=""!(SUB="") S ERRTX="Unknown Exam Type" G ^MCAR7X
F P=1:1 S VAL=$T(VARS+P) Q:VAL="" S SET($P(VAL,";",3))=$P(VAL,";",4,5)
S X=$P($P(SEG("OBR"),"|",33),"^",1)
I +X,$$GET1^DIQ(200,X,.01,"I")'="" S $P(SET("Interpreter"),";",3)=X
OBX ; Process OBX
S X=$G(MSG(NUM)) G:X="" UPDATE I $E(X,1,3)'="OBX" S ERRTX="OBX not found when expected" G ^MCAR7X
S SEG("OBX")=X
S STYP=$P(X,"|",3) I STYP'="ST" G IMP
S CODE=$P(X,"|",4),VAL=$P(X,"|",6),UNITS=$P(X,"|",7) I CODE["^" S CODE=$P(CODE,"^",2)
I CODE=""!(VAL="") G NEXT
I $D(SET(CODE)) S $P(SET(CODE),";",3)=VAL
NEXT S NUM=NUM+1 G OBX
IMP ; Get Impression
S NUM=NUM+1,VAL=$P(X,"|",6) I STYP="CE" S VAL=$P(VAL,"^",2)
S ICNT=ICNT+1,IMP(ICNT)=VAL G OBX
UPDATE ; Update File
D PROC^MCAR7A ; Set Procedure Entry
I EXAM=93000 S ID="" F S ID=$O(SET(ID)) Q:ID="" S P=$P(SET(ID),";",1) I P'="" S K=$P(SET(ID),";",2) I K'="" S VAL=$P(SET(ID),";",3) S:VAL'="" $P(^MCAR(FIL,DA,P),"^",K)=VAL
I $D(IMP) F P=1:1:ICNT S ^MCAR(FIL,DA,SUB,P,0)=IMP(P)
I S ^MCAR(FIL,DA,SUB,0)="^^"_ICNT_"^"_ICNT_"^"_DT
S DIK="^MCAR("_FIL_"," D IX1^DIK
D GENACK^MCAR7X
Q
93000 ;;EKG;691.5;9
93040 ;;Pacemaker;698.3;10
93015 ;;Exercise;691.7;6
93266 ;;Holter;691.6;7
93529 ;;Cath;691.1;43
93307 ;;Echo;691;3
93619 ;;Electrophysiology;691.8;12
VARS ;;
;;Interpreter;0;13
;;Systolic Blood Pressure;4;2
;;Diastolic Blood Pressure;4;1
;;Ventricular Rate;0;4
;;Atrial Rate;
;;P-R Interval;0;5
;;QRS Duration;0;6
;;QT;0;7
;;QTc;0;8
;;P Axis;0;9
;;QRS Axis;
;;T Axis;0;11
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCAR7M1 1735 printed Dec 13, 2024@02:11:48 Page 2
MCAR7M1 ; HIRMFO/REL-Muse EKG ;6/7/00 10:11
+1 ;;2.3;Medicine;**24**;09/13/1996
+2 SET EXAM=$PIECE($PIECE(SEG("OBR"),"|",5),"^",1)
if EXAM=""
SET EXAM=99999
+3 SET X=$TEXT(@EXAM)
SET FIL=$PIECE(X,";",4)
SET SUB=$PIECE(X,";",5)
IF FIL=""!(SUB="")
SET ERRTX="Unknown Exam Type"
GOTO ^MCAR7X
+4 FOR P=1:1
SET VAL=$TEXT(VARS+P)
if VAL=""
QUIT
SET SET($PIECE(VAL,";",3))=$PIECE(VAL,";",4,5)
+5 SET X=$PIECE($PIECE(SEG("OBR"),"|",33),"^",1)
+6 IF +X
IF $$GET1^DIQ(200,X,.01,"I")'=""
SET $PIECE(SET("Interpreter"),";",3)=X
OBX ; Process OBX
+1 SET X=$GET(MSG(NUM))
if X=""
GOTO UPDATE
IF $EXTRACT(X,1,3)'="OBX"
SET ERRTX="OBX not found when expected"
GOTO ^MCAR7X
+2 SET SEG("OBX")=X
+3 SET STYP=$PIECE(X,"|",3)
IF STYP'="ST"
GOTO IMP
+4 SET CODE=$PIECE(X,"|",4)
SET VAL=$PIECE(X,"|",6)
SET UNITS=$PIECE(X,"|",7)
IF CODE["^"
SET CODE=$PIECE(CODE,"^",2)
+5 IF CODE=""!(VAL="")
GOTO NEXT
+6 IF $DATA(SET(CODE))
SET $PIECE(SET(CODE),";",3)=VAL
NEXT SET NUM=NUM+1
GOTO OBX
IMP ; Get Impression
+1 SET NUM=NUM+1
SET VAL=$PIECE(X,"|",6)
IF STYP="CE"
SET VAL=$PIECE(VAL,"^",2)
+2 SET ICNT=ICNT+1
SET IMP(ICNT)=VAL
GOTO OBX
UPDATE ; Update File
+1 ; Set Procedure Entry
DO PROC^MCAR7A
+2 IF EXAM=93000
SET ID=""
FOR
SET ID=$ORDER(SET(ID))
if ID=""
QUIT
SET P=$PIECE(SET(ID),";",1)
IF P'=""
SET K=$PIECE(SET(ID),";",2)
IF K'=""
SET VAL=$PIECE(SET(ID),";",3)
if VAL'=""
SET $PIECE(^MCAR(FIL,DA,P),"^",K)=VAL
+3 IF $DATA(IMP)
FOR P=1:1:ICNT
SET ^MCAR(FIL,DA,SUB,P,0)=IMP(P)
+4 IF $TEST
SET ^MCAR(FIL,DA,SUB,0)="^^"_ICNT_"^"_ICNT_"^"_DT
+5 SET DIK="^MCAR("_FIL_","
DO IX1^DIK
+6 DO GENACK^MCAR7X
+7 QUIT
93000 ;;EKG;691.5;9
93040 ;;Pacemaker;698.3;10
93015 ;;Exercise;691.7;6
93266 ;;Holter;691.6;7
93529 ;;Cath;691.1;43
93307 ;;Echo;691;3
93619 ;;Electrophysiology;691.8;12
VARS ;;
+1 ;;Interpreter;0;13
+2 ;;Systolic Blood Pressure;4;2
+3 ;;Diastolic Blood Pressure;4;1
+4 ;;Ventricular Rate;0;4
+5 ;;Atrial Rate;
+6 ;;P-R Interval;0;5
+7 ;;QRS Duration;0;6
+8 ;;QT;0;7
+9 ;;QTc;0;8
+10 ;;P Axis;0;9
+11 ;;QRS Axis;
+12 ;;T Axis;0;11
