MCARAMLG ;WASH ISC/JKL-MUSE AUTO INSTRUMENT RETRANSMISSION-EKG CORR ;2/27/95 19:42
;;2.3;Medicine;;09/13/1996
;
;
;Called from ^MCARAML
;Retransmits EKG external date cross-reference,
;EKG date cross-reference without record, without transaction
;EKG PID cross-reference without record,
;EKG automated record with defunct delete status
N MCNAME,MCSSN,MCDATE,MCIEN,MCZERO,MCI,MCJ,X,D,DIC,Y,MCK
;Retransmits EKG external date cross-reference
S MCDATE=9999999
F MCI=1:1 S MCDATE=$O(^MCAR(691.5,"B",MCDATE)) Q:MCDATE="" I MCDATE'="ES" S MCIEN=0 F MCK=1:1 S MCIEN=$O(^MCAR(691.5,"B",MCDATE,MCIEN)) Q:MCIEN="" D SAVE
;EKG date cross-reference without transaction
S MCDATE=0
F MCI=1:1 S MCDATE=$O(^MCAR(691.5,"B",MCDATE)) Q:MCDATE=""!(+MCDATE>9999999) I '$D(^MCAR(700.5,"B",MCDATE)) S MCIEN=0 F MCK=1:1 S MCIEN=$O(^MCAR(691.5,"B",MCDATE,MCIEN)) Q:MCIEN="" D SAVE
;EKG automated record with defunct delete status
;EKG PID cross-reference without record,
S (MCIEN,MCERR)=0
F MCI=1:1 S MCIEN=$O(^MCAR(691.5,MCIEN)) Q:MCIEN=""!(MCIEN="B") S MCERR=0 D DEF S MCERR=1 D SAVE
Q
;
DEF ;
I '$D(^MCAR(691.5,MCIEN,"A")) Q
I '$D(^MCAR(691.5,MCIEN,"ES")) Q
I $P(^MCAR(691.5,MCIEN,"ES"),"^",12)=1 D SAVE
Q
;
SAVE ;
I '$D(^MCAR(691.5,MCIEN,0)) Q
S MCSSN="" S:$D(^MCAR(691.5,MCIEN,.1)) MCSSN=^MCAR(691.5,MCIEN,.1)
S MCZERO=^MCAR(691.5,MCIEN,0)
S MCPID=$P(MCZERO,"^",2),MCNAME=""
I '$D(MCDATE) S MCDATE=$P(MCZERO,"^") I MCDATE="" S MCDATE="NO DATE"
S X=MCSSN,DIC="^DPT(",D="SSN",DIC(0)="XZ" D IX^DIC
S:+Y>0 MCNAME=$P(Y(0),"^")
I (MCERR=1),MCPID'="",$D(^MCAR(691.5,"C",MCPID)) Q
D SET Q
;
SET ;
I MCNAME="",MCSSN="",MCDATE="" Q
I MCNAME="" S MCNAME="NO PATIENT NAME"
I MCSSN="" S MCSSN="NO SSN"
I MCDATE="" S MCDATE="NO DATE"
I $L(MCNAME)<30 F MCJ=$L(MCNAME):1:30 S MCNAME=MCNAME_" "
I $L(MCSSN)<10 F MCJ=$L(MCSSN):1:10 S MCSSN=MCSSN_" "
I $D(^TMP($J,0,"MC",MCNAME,MCSSN,MCDATE)) Q
S MCCNT=MCCNT+1 W:MCCNT#100=0 "."
S ^TMP($J,0,"MC",MCNAME,MCSSN,MCDATE)=""
S ^TMP($J,0,"MC",0)=MCCNT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARAMLG 2063 printed Apr 09, 2024@21:15:03 Page 2
MCARAMLG ;WASH ISC/JKL-MUSE AUTO INSTRUMENT RETRANSMISSION-EKG CORR ;2/27/95 19:42
+1 ;;2.3;Medicine;;09/13/1996
+2 ;
+3 ;
+4 ;Called from ^MCARAML
+5 ;Retransmits EKG external date cross-reference,
+6 ;EKG date cross-reference without record, without transaction
+7 ;EKG PID cross-reference without record,
+8 ;EKG automated record with defunct delete status
+9 NEW MCNAME,MCSSN,MCDATE,MCIEN,MCZERO,MCI,MCJ,X,D,DIC,Y,MCK
+10 ;Retransmits EKG external date cross-reference
+11 SET MCDATE=9999999
+12 FOR MCI=1:1
SET MCDATE=$ORDER(^MCAR(691.5,"B",MCDATE))
if MCDATE=""
QUIT
IF MCDATE'="ES"
SET MCIEN=0
FOR MCK=1:1
SET MCIEN=$ORDER(^MCAR(691.5,"B",MCDATE,MCIEN))
if MCIEN=""
QUIT
DO SAVE
+13 ;EKG date cross-reference without transaction
+14 SET MCDATE=0
+15 FOR MCI=1:1
SET MCDATE=$ORDER(^MCAR(691.5,"B",MCDATE))
if MCDATE=""!(+MCDATE>9999999)
QUIT
IF '$DATA(^MCAR(700.5,"B",MCDATE))
SET MCIEN=0
FOR MCK=1:1
SET MCIEN=$ORDER(^MCAR(691.5,"B",MCDATE,MCIEN))
if MCIEN=""
QUIT
DO SAVE
+16 ;EKG automated record with defunct delete status
+17 ;EKG PID cross-reference without record,
+18 SET (MCIEN,MCERR)=0
+19 FOR MCI=1:1
SET MCIEN=$ORDER(^MCAR(691.5,MCIEN))
if MCIEN=""!(MCIEN="B")
QUIT
SET MCERR=0
DO DEF
SET MCERR=1
DO SAVE
+20 QUIT
+21 ;
DEF ;
+1 IF '$DATA(^MCAR(691.5,MCIEN,"A"))
QUIT
+2 IF '$DATA(^MCAR(691.5,MCIEN,"ES"))
QUIT
+3 IF $PIECE(^MCAR(691.5,MCIEN,"ES"),"^",12)=1
DO SAVE
+4 QUIT
+5 ;
SAVE ;
+1 IF '$DATA(^MCAR(691.5,MCIEN,0))
QUIT
+2 SET MCSSN=""
if $DATA(^MCAR(691.5,MCIEN,.1))
SET MCSSN=^MCAR(691.5,MCIEN,.1)
+3 SET MCZERO=^MCAR(691.5,MCIEN,0)
+4 SET MCPID=$PIECE(MCZERO,"^",2)
SET MCNAME=""
+5 IF '$DATA(MCDATE)
SET MCDATE=$PIECE(MCZERO,"^")
IF MCDATE=""
SET MCDATE="NO DATE"
+6 SET X=MCSSN
SET DIC="^DPT("
SET D="SSN"
SET DIC(0)="XZ"
DO IX^DIC
+7 if +Y>0
SET MCNAME=$PIECE(Y(0),"^")
+8 IF (MCERR=1)
IF MCPID'=""
IF $DATA(^MCAR(691.5,"C",MCPID))
QUIT
+9 DO SET
QUIT
+10 ;
SET ;
+1 IF MCNAME=""
IF MCSSN=""
IF MCDATE=""
QUIT
+2 IF MCNAME=""
SET MCNAME="NO PATIENT NAME"
+3 IF MCSSN=""
SET MCSSN="NO SSN"
+4 IF MCDATE=""
SET MCDATE="NO DATE"
+5 IF $LENGTH(MCNAME)<30
FOR MCJ=$LENGTH(MCNAME):1:30
SET MCNAME=MCNAME_" "
+6 IF $LENGTH(MCSSN)<10
FOR MCJ=$LENGTH(MCSSN):1:10
SET MCSSN=MCSSN_" "
+7 IF $DATA(^TMP($JOB,0,"MC",MCNAME,MCSSN,MCDATE))
QUIT
+8 SET MCCNT=MCCNT+1
if MCCNT#100=0
WRITE "."
+9 SET ^TMP($JOB,0,"MC",MCNAME,MCSSN,MCDATE)=""
+10 SET ^TMP($JOB,0,"MC",0)=MCCNT
+11 QUIT
