- 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 Jan 18, 2025@03:13 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