MCARAMLG.m

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

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