source: WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNPED.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: 3.2 KB
Line 
1AUPNPED ; IHS/CMI/LAB - EDITS FOR PATIENT FILES ;
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**167**;Aug 12, 1996;Build 22
3NAME ;ENTRY POINT FOR NAME
4 I X[""""!(X'?1U.AP)!(X'[",")!(X?.E1","." ")!(X?.E1","." "1",".E)!($L(X,",")>3)!($L(X,".")>3)!($L(X,"-")>6)!($L(X,"(")>2)!($L(X,")")>2)!($L(X)>30)!($L(X)<3)!(X?.E1", ".E) K X Q
5 F L=1:0 S L=$F(X," ",L) Q:L=0 S:$E(X,L-2)?1P!($E(X,L)?1P)!(L>$L(X)) X=$E(X,1,L-2)_$E(X,L,99),L=L-1
6 S AUPNNAMX=X
7 F AUPNII=$L(AUPNNAMX):-1:1 S:"/:;`*()_+=&%$#@![]{}|\?<>~"""[$E(AUPNNAMX,AUPNII) AUPNNAMX=$E(AUPNNAMX,1,AUPNII-1)_$E(AUPNNAMX,AUPNII+1,245)
8 I AUPNNAMX'=X K X
9 I $D(X) S X=$$UP^XLFSTR(X) ;IHS/ANMC/LJF 8/4/97 to convert to all caps
10 K AUPNNAMX,AUPNII
11 Q
12PAT1109 ;EP
13 S PAT="PAT1109A" G QTM
14QTM D QUANTUM Q:'$D(X) Q:$E(X,1,2)="UN"!(X="NONE") D @PAT G:'$D(AUPNX) KILL K:LKDATA="NONE" X G:+LKDATA=0 KILL K:X="FULL" X G:'$D(X) KILL K:($P(X,"/",1)/$P(X,"/",2))>($P(LKDATA,"/",1)/$P(LKDATA,"/",2)) X G KILL
15PAT1109A S AUPNX=X S LKDA=DA,LKDR=1110,LKDIC=9000001,LKDRENT=0 D ^AUPNFMLK K:$D(LKERR) AUPNX Q
16KILL K AUPNX,LKDATA,LKDENT,LKG,LKGL,LKPCC,LKPRINT Q
17PAT1110 ;EP
18 D QUANTUM Q:'$D(X) Q:$E(X,1,2)="UN"!(X="FULL") D PAT1110A G:'$D(AUPNX) KILL K:LKDATA="FULL" X G:+LKDATA=0 KILL K:+X=0 X G:'$D(X) KILL K:($P(X,"/",1)/$P(X,"/",2))<($P(LKDATA,"/",1)/$P(LKDATA,"/",2)) X G KILL
19PAT1110A S AUPNX=X S LKDA=DA,LKDR=1109,LKDIC=9000001,LKDRENT=0 D ^AUPNFMLK K:$D(LKERR) AUPNX Q
20PAT4101 ;
21 Q:'$D(^AUPNPAT("D",X))
22 S AUPNPED("NXT")="" F AUPNPED("L")=0:0 S AUPNPED("NXT")=$O(^AUPNPAT("D",X,AUPNPED("NXT"))) Q:AUPNPED("NXT")="" I AUPNPED("NXT")'=DA(1),$D(^AUPNPAT("D",X,AUPNPED("NXT"),DA)) W " <Already used> " K X Q
23 K AUPNPED("NXT"),AUPNPED("L")
24 Q
25PAT4302 ;EP
26 S PAT="PAT4302A" G QTM
27PAT4302A S AUPNX=X,(AUPNY,LKDA)=DA(1),LKDR=1110,LKDIC=9000001,LKDRENT=0 D ^AUPNFMLK K AUPNY K:$D(LKERR) AUPNX Q
28QUANTUM K:$L(X)>11!($L(X)<1) X Q:'$D(X) I "NF"[$E(X) S X=$S($E(X)="F":"FULL",1:"NONE") Q
29 K:$E(X)'?1N&(($E(X,1,3)'="UNK")&($E(X,1,3)'="UNS")) X Q:'$D(X) I $E(X)="U" S X=$S($E(X,3)="K":"UNKNOWN",1:"UNSPECIFIED") Q
30 K:X'?1.4N1"/"1.5N X Q:'$D(X) K:$P(X,"/",1)>$P(X,"/",2)!(+$P(X,"/",2)=0) X Q:'$D(X) S:$P(X,"/",1)=$P(X,"/",2) X="FULL" Q
31PAT5101 ;EP
32 S AUPNX=X S:$D(AUPNDOB) LKDATA=AUPNDOB G PAT5101A:$D(AUPNDOB) S LKDA=DA,LKDR=.03,LKDIC=2,LKDRENT=0 D ^AUPNFMLK G:$D(LKERR) PAT5101X
33PAT5101A K:$E(AUPNX,1,7)<LKDATA AUPNX G PAT5101X:'$D(AUPNX) S:$D(AUPNDOD) LKDATA=AUPNDOD G PAT5101B:$D(AUPNDOD) S LKDA=DA,LKDR=.351,LKDIC=2,LKDRENT=0 D ^AUPNFMLK G:$D(LKERR) PAT5101X
34PAT5101B I LKDATA'="",$E(AUPNX,1,7)>LKDATA K AUPNX
35PAT5101X S:$D(AUPNX) X=AUPNX K:'$D(AUPNX) X K LKDATA,LKDENT,LKG,LKGL,LKPCC,LKPRINT Q
36RRENUM K:'(X?6N)&'(X?9N) X Q:'$D(X) Q:X?6N S AUPNX=X,LKDA=DA,LKDR=.03,LKDIC=9000005 D ^AUPNFMLK K:'$D(LKPRINT) X,AUPNX Q:'$D(AUPNX)
37 F LKI="H","MH","WH","WCH","PH","JA" K:LKI=LKPRINT&'(X?6N) X,LKI,AUPNX Q:'$D(AUPNX)
38 K LKI Q
39RREPFX Q:X="" Q:'$D(^AUTTRRP(X)) S AUX=$P(^AUTTRRP(X,0),"^",1)
40 G RREPFX1:'((AUX="H")!(AUX="MH")!(AUX="WH")!(AUX="WCH")!(AUX="PH")!(AUX="JA")) S LKDA=DA,LKDR=.04,LKDIC=9000005 D ^AUPNFMLK Q:'$D(LKPRINT) Q:$L(LKPRINT)=6!(LKPRINT="")
41 W *7,!,"This prefix requires that the number be 6 characters long.",!,"Change the number, then re-enter the prefix.",! K X
42RREPFX1 K AUX G KILL
Note: See TracBrowser for help on using the repository browser.