MCAR7E ; HIRMFO/REL-Olympus/CMore Endoscopy ;7/24/00 11:16
;;2.3;Medicine;**24**;09/13/1996
OBX ; Process OBX
S X=$G(MSG(NUM)) I $E(X,1,3)'="OBX" S ERRTX="OBX not found when expected" G ^MCAR7X
S SEG("OBX")=X
UPDATE ; Update File
S FIL=699 D PROC^MCAR7A ; Set Procedure entry
; Process Note
S LN=0,J=0,^MCAR(699,DA,33,0)="^^0^0^"_DT_"^"
I MCAPP="OLYMPUS" S SEP="^" G OLY
I MCAPP="PENTAX" S SEP="^" G PEN
I MCAPP="CMore" S SEP="~"
CMO ; Process CMore
S LINE=$P(MSG(NUM),"|",6)
U1 I LINE[SEP D C1 G U1
S J=J+1 I $G(MSG(NUM,J))="" D:LINE'="" C1 G U2
S LINE=LINE_MSG(NUM,J) S:LINE["|" LINE=$P(LINE,"|",1) G U1
C1 S LN=LN+1,%=$P(LINE,SEP,1),LINE=$P(LINE,SEP,2,999)
S:%="" %=" " S ^MCAR(699,DA,33,LN,0)=% Q
OLY ; Process Olympus
F S LINE=$P($G(MSG(NUM)),"|",6) Q:LINE="" D U3 S NUM=NUM+1
G U2
PEN ; Process Pentax data
N LN
S LN=0
F S LINE=$P($G(MSG(NUM)),"|",6) Q:'$D(MSG(NUM)) D S NUM=NUM+1
.S LN=LN+1
.S ^MCAR(699,DA,33,LN,0)=LINE
.Q
G U2
U2 S $P(^MCAR(699,DA,33,0),"^",3,4)=(LN_"^"_LN)
S:EXAM="" EXAM="Endoscopy" S PIEN=$O(^MCAR(697.2,"B",EXAM,0))
I PIEN="" S:EXAM2'="" PIEN=$O(^MCAR(697.2,"B",EXAM2,0))
I PIEN="" D
.K DIC S (DIC,DLAYGO)=697.2,DIC(0)="L",X=$C(34)_EXAM_$C(34)
.S DIC("DR")="1///MCAR(699;1.1///.02;3///G;4///ENDO;5///MCARGP;6///GI;7///"_EXAM_";11///1;12///MCKEYGI;13///1;15///1;1001///P"
.D ^DIC S PIEN=+Y K DIC,DLAYGO Q
S $P(^MCAR(699,DA,0),"^",12)=PIEN
; Re-index record
S DIK="^MCAR(699," D IX1^DIK
D GENACK^MCAR7X
Q
U3 ; Add a line
S J=0 D NJ
U4 S %=$L(LINE)+1 I %<80 G:NEXT="" ST D G U4
.S LINE=LINE_$E(NEXT,1,125),NEXT=$E(NEXT,126,999) D:NEXT="" NJ
.Q
F %=79:-1:1 Q:$E(LINE,%)=" "
D ST G U4
NJ S J=J+1,NEXT=$P($G(MSG(NUM,J)),"|",1) Q
ST S LN=LN+1,^MCAR(699,DA,33,LN,0)=$E(LINE,1,%-1),LINE=$E(LINE,%+1,999) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCAR7E 1824 printed Apr 09, 2024@21:17:31 Page 2
MCAR7E ; HIRMFO/REL-Olympus/CMore Endoscopy ;7/24/00 11:16
+1 ;;2.3;Medicine;**24**;09/13/1996
OBX ; Process OBX
+1 SET X=$GET(MSG(NUM))
IF $EXTRACT(X,1,3)'="OBX"
SET ERRTX="OBX not found when expected"
GOTO ^MCAR7X
+2 SET SEG("OBX")=X
UPDATE ; Update File
+1 ; Set Procedure entry
SET FIL=699
DO PROC^MCAR7A
+2 ; Process Note
+3 SET LN=0
SET J=0
SET ^MCAR(699,DA,33,0)="^^0^0^"_DT_"^"
+4 IF MCAPP="OLYMPUS"
SET SEP="^"
GOTO OLY
+5 IF MCAPP="PENTAX"
SET SEP="^"
GOTO PEN
+6 IF MCAPP="CMore"
SET SEP="~"
CMO ; Process CMore
+1 SET LINE=$PIECE(MSG(NUM),"|",6)
U1 IF LINE[SEP
DO C1
GOTO U1
+1 SET J=J+1
IF $GET(MSG(NUM,J))=""
if LINE'=""
DO C1
GOTO U2
+2 SET LINE=LINE_MSG(NUM,J)
if LINE["|"
SET LINE=$PIECE(LINE,"|",1)
GOTO U1
C1 SET LN=LN+1
SET %=$PIECE(LINE,SEP,1)
SET LINE=$PIECE(LINE,SEP,2,999)
+1 if %=""
SET %=" "
SET ^MCAR(699,DA,33,LN,0)=%
QUIT
OLY ; Process Olympus
+1 FOR
SET LINE=$PIECE($GET(MSG(NUM)),"|",6)
if LINE=""
QUIT
DO U3
SET NUM=NUM+1
+2 GOTO U2
PEN ; Process Pentax data
+1 NEW LN
+2 SET LN=0
+3 FOR
SET LINE=$PIECE($GET(MSG(NUM)),"|",6)
if '$DATA(MSG(NUM))
QUIT
Begin DoDot:1
+4 SET LN=LN+1
+5 SET ^MCAR(699,DA,33,LN,0)=LINE
+6 QUIT
End DoDot:1
SET NUM=NUM+1
+7 GOTO U2
U2 SET $PIECE(^MCAR(699,DA,33,0),"^",3,4)=(LN_"^"_LN)
+1 if EXAM=""
SET EXAM="Endoscopy"
SET PIEN=$ORDER(^MCAR(697.2,"B",EXAM,0))
+2 IF PIEN=""
if EXAM2'=""
SET PIEN=$ORDER(^MCAR(697.2,"B",EXAM2,0))
+3 IF PIEN=""
Begin DoDot:1
+4 KILL DIC
SET (DIC,DLAYGO)=697.2
SET DIC(0)="L"
SET X=$CHAR(34)_EXAM_$CHAR(34)
+5 SET DIC("DR")="1///MCAR(699;1.1///.02;3///G;4///ENDO;5///MCARGP;6///GI;7///"_EXAM_";11///1;12///MCKEYGI;13///1;15///1;1001///P"
+6 DO ^DIC
SET PIEN=+Y
KILL DIC,DLAYGO
QUIT
End DoDot:1
+7 SET $PIECE(^MCAR(699,DA,0),"^",12)=PIEN
+8 ; Re-index record
+9 SET DIK="^MCAR(699,"
DO IX1^DIK
+10 DO GENACK^MCAR7X
+11 QUIT
U3 ; Add a line
+1 SET J=0
DO NJ
U4 SET %=$LENGTH(LINE)+1
IF %<80
if NEXT=""
GOTO ST
Begin DoDot:1
+1 SET LINE=LINE_$EXTRACT(NEXT,1,125)
SET NEXT=$EXTRACT(NEXT,126,999)
if NEXT=""
DO NJ
+2 QUIT
End DoDot:1
GOTO U4
+3 FOR %=79:-1:1
if $EXTRACT(LINE,%)=" "
QUIT
+4 DO ST
GOTO U4
NJ SET J=J+1
SET NEXT=$PIECE($GET(MSG(NUM,J)),"|",1)
QUIT
ST SET LN=LN+1
SET ^MCAR(699,DA,33,LN,0)=$EXTRACT(LINE,1,%-1)
SET LINE=$EXTRACT(LINE,%+1,999)
QUIT
