| [613] | 1 | AUPNPED ; IHS/CMI/LAB - EDITS FOR PATIENT FILES ;
|
|---|
| 2 | ;;1.0;PCE PATIENT CARE ENCOUNTER;**167**;Aug 12, 1996;Build 22
|
|---|
| 3 | NAME ;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
|
|---|
| 12 | PAT1109 ;EP
|
|---|
| 13 | S PAT="PAT1109A" G QTM
|
|---|
| 14 | QTM 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
|
|---|
| 15 | PAT1109A S AUPNX=X S LKDA=DA,LKDR=1110,LKDIC=9000001,LKDRENT=0 D ^AUPNFMLK K:$D(LKERR) AUPNX Q
|
|---|
| 16 | KILL K AUPNX,LKDATA,LKDENT,LKG,LKGL,LKPCC,LKPRINT Q
|
|---|
| 17 | PAT1110 ;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
|
|---|
| 19 | PAT1110A S AUPNX=X S LKDA=DA,LKDR=1109,LKDIC=9000001,LKDRENT=0 D ^AUPNFMLK K:$D(LKERR) AUPNX Q
|
|---|
| 20 | PAT4101 ;
|
|---|
| 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
|
|---|
| 25 | PAT4302 ;EP
|
|---|
| 26 | S PAT="PAT4302A" G QTM
|
|---|
| 27 | PAT4302A S AUPNX=X,(AUPNY,LKDA)=DA(1),LKDR=1110,LKDIC=9000001,LKDRENT=0 D ^AUPNFMLK K AUPNY K:$D(LKERR) AUPNX Q
|
|---|
| 28 | QUANTUM 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
|
|---|
| 31 | PAT5101 ;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
|
|---|
| 33 | PAT5101A 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
|
|---|
| 34 | PAT5101B I LKDATA'="",$E(AUPNX,1,7)>LKDATA K AUPNX
|
|---|
| 35 | PAT5101X S:$D(AUPNX) X=AUPNX K:'$D(AUPNX) X K LKDATA,LKDENT,LKG,LKGL,LKPCC,LKPRINT Q
|
|---|
| 36 | RRENUM 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
|
|---|
| 39 | RREPFX 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
|
|---|
| 42 | RREPFX1 K AUX G KILL
|
|---|
