source: WorldVistAEHR/trunk/r/OCCURRENCE_SCREEN-QAO/QAOSOCID.m@ 701

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

initial load of WorldVistAEHR

File size: 1.3 KB
Line 
1QAOSOCID ;HISC/JES-COMPOSE OCCURRENCE SCREEN IDENTIFICATION NUMBER ;2/4/93 08:39
2 ;;3.0;Occurrence Screen;;09/14/1993
3 S QACODE=^QA(741,DA,0),QANAME=$P(QACODE,"^",1),QADATE1=$P(QACODE,"^",3)
4 Q:(QANAME="")!(QADATE1="") Q:'$D(^DPT(QANAME,0))
5 S QANAME=$P(^DPT(QANAME,0),"^"),QACODE(0)=0
6MONTH ; (1) MONTH OF OCCURRENCE (ALPHA A THROUGH L)
7 S QAOSCODE=$C($E(QADATE1,4,5)+64)
8DAY ; (2) DAY OF OCCURRENCE (ALPHA A THROUGH Z, 27=1,28=2,29=3,30=4,31=5)
9 S QALDAY=$E(QADATE1,6,7)
10 S QAOSCODE=QAOSCODE_$S(QALDAY>26:QALDAY-26,1:$C(QALDAY+64))
11LNAME ; (3) LAST NAME (FIRST LETTER OF LAST NAME)
12 S QAOSCODE=QAOSCODE_$E(QANAME)
13FUDGE ; (4-6) FUDGE (LAST 3 DIGITS OF: IEN + LAST 4 DIGITS OF SSN + FUDGE)
14 S QASSN=$E($P(^DPT(+QACODE,0),"^",9),6,9)+DA+QACODE(0)
15 S QASSN="000"_QASSN,QAOSCODE=QAOSCODE_$E(QASSN,$L(QASSN)-2,$L(QASSN))
16FNAME ; (7) FIRST NAME (FIRST LETTER OF FIRST NAME)
17 S QAOSCODE=QAOSCODE_$E($P(QANAME,",",2))
18 I $D(^QA(741,"E",QAOSCODE)),$O(^QA(741,"E",QAOSCODE,0))'=DA,QACODE(0)'>999 S QACODE(0)=QACODE(0)+1 G MONTH
19XREF ; EXECUTE SET AND KILL LOGIC
20 S $P(^QA(741,DA,0),"^",4)=QAOSCODE,X=QAOSCODE
21 N QAQAXREF,QAQADICT,QAQAFLD S QAQADICT=741,QAQAFLD=2 D ENSET^QAQAXREF
22 K I,QACODE,QANAME,QADATE1,QALDAY,QASSN,QAOSCODE,X
23 Q
24KILL ;
25 N QAQAXREF,QAQADICT,QAQAFLD
26 S X=$P(^QA(741,DA,0),"^",4),QAQADICT=741,QAQAFLD=2
27 D ENKILL^QAQAXREF S $P(^QA(741,DA,0),"^",4)=""
28 Q
Note: See TracBrowser for help on using the repository browser.