38 lines
1.3 KiB
Mathematica
38 lines
1.3 KiB
Mathematica
MCARAMLC ;WASH ISC/JKL-MUSE AUTO INSTRUMENT RETRANSMISSION NO TRAN ;2/27/95 17:18
|
|
;;2.3;Medicine;;09/13/1996
|
|
;
|
|
;
|
|
;Called from ^MCARAML
|
|
;Retransmits no EKG date cross-reference, misidentified PID
|
|
N MCNAME,MCSSN,MCDATE,MCPID,MCZERO,MCNAME2,MCI,MCJ,X,D,DIC,Y,MCK
|
|
N MCIEN,MCIEN2,MCERR
|
|
S (MCIEN,MCIEN2)=0
|
|
F MCI=1:1 S MCIEN=$O(^MCAR(691.5,MCIEN)) Q:MCIEN=""!(MCIEN="B") D SAVE
|
|
Q
|
|
;
|
|
SAVE ;
|
|
I '$D(^MCAR(691.5,MCIEN,0)) Q
|
|
S MCSSN="" I $D(^MCAR(691.5,MCIEN,.1)) S MCSSN=^MCAR(691.5,MCIEN,.1)
|
|
S MCZERO=^MCAR(691.5,MCIEN,0),MCNAME2=""
|
|
S MCDATE=$P(MCZERO,"^"),MCPID=$P(MCZERO,"^",2),MCNAME=""
|
|
I MCDATE="" Q
|
|
S X=MCSSN,DIC="^DPT(",D="SSN",DIC(0)="XZ" D IX^DIC
|
|
S:+Y>0 MCNAME=$P(Y(0),"^")
|
|
I MCPID'="",$D(^DPT(MCPID,0)) S MCNAME2=$P(^DPT(MCPID,0),"^")
|
|
I MCNAME'=MCNAME2 D SET Q
|
|
I '$D(^MCAR(700.5,"B",MCDATE)) D SET Q
|
|
I '$D(^MCAR(691.5,"B",MCDATE)) D SET Q
|
|
S MCERR=1 F MCK=1:1 S MCIEN2=$O(^MCAR(700.5,"B",MCDATE,MCIEN2)) Q:MCIEN2="" I $D(^MCAR(700.5,MCIEN2,0)),$P(^MCAR(700.5,MCIEN2,0),"^",3)=MCSSN S MCERR=0
|
|
I MCERR>0 D SET
|
|
Q
|
|
SET ;
|
|
I MCNAME="" S MCNAME="NO PATIENT NAME"
|
|
I MCSSN="" S MCSSN="NO SSN"
|
|
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
|