source: WorldVistAEHR/trunk/r/MEDICINE-MC/MCARAMLG.m@ 1766

Last change on this file since 1766 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.0 KB
RevLine 
[613]1MCARAMLG ;WASH ISC/JKL-MUSE AUTO INSTRUMENT RETRANSMISSION-EKG CORR ;2/27/95 19:42
2 ;;2.3;Medicine;;09/13/1996
3 ;
4 ;
5 ;Called from ^MCARAML
6 ;Retransmits EKG external date cross-reference,
7 ;EKG date cross-reference without record, without transaction
8 ;EKG PID cross-reference without record,
9 ;EKG automated record with defunct delete status
10 N MCNAME,MCSSN,MCDATE,MCIEN,MCZERO,MCI,MCJ,X,D,DIC,Y,MCK
11 ;Retransmits EKG external date cross-reference
12 S MCDATE=9999999
13 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
14 ;EKG date cross-reference without transaction
15 S MCDATE=0
16 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
17 ;EKG automated record with defunct delete status
18 ;EKG PID cross-reference without record,
19 S (MCIEN,MCERR)=0
20 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
21 Q
22 ;
23DEF ;
24 I '$D(^MCAR(691.5,MCIEN,"A")) Q
25 I '$D(^MCAR(691.5,MCIEN,"ES")) Q
26 I $P(^MCAR(691.5,MCIEN,"ES"),"^",12)=1 D SAVE
27 Q
28 ;
29SAVE ;
30 I '$D(^MCAR(691.5,MCIEN,0)) Q
31 S MCSSN="" S:$D(^MCAR(691.5,MCIEN,.1)) MCSSN=^MCAR(691.5,MCIEN,.1)
32 S MCZERO=^MCAR(691.5,MCIEN,0)
33 S MCPID=$P(MCZERO,"^",2),MCNAME=""
34 I '$D(MCDATE) S MCDATE=$P(MCZERO,"^") I MCDATE="" S MCDATE="NO DATE"
35 S X=MCSSN,DIC="^DPT(",D="SSN",DIC(0)="XZ" D IX^DIC
36 S:+Y>0 MCNAME=$P(Y(0),"^")
37 I (MCERR=1),MCPID'="",$D(^MCAR(691.5,"C",MCPID)) Q
38 D SET Q
39 ;
40SET ;
41 I MCNAME="",MCSSN="",MCDATE="" Q
42 I MCNAME="" S MCNAME="NO PATIENT NAME"
43 I MCSSN="" S MCSSN="NO SSN"
44 I MCDATE="" S MCDATE="NO DATE"
45 I $L(MCNAME)<30 F MCJ=$L(MCNAME):1:30 S MCNAME=MCNAME_" "
46 I $L(MCSSN)<10 F MCJ=$L(MCSSN):1:10 S MCSSN=MCSSN_" "
47 I $D(^TMP($J,0,"MC",MCNAME,MCSSN,MCDATE)) Q
48 S MCCNT=MCCNT+1 W:MCCNT#100=0 "."
49 S ^TMP($J,0,"MC",MCNAME,MCSSN,MCDATE)=""
50 S ^TMP($J,0,"MC",0)=MCCNT
51 Q
Note: See TracBrowser for help on using the repository browser.