AUPNPED ; IHS/CMI/LAB - EDITS FOR PATIENT FILES ;
;;99.1;IHS DICTIONARIES (PATIENT);**18,19**;MAR 09, 1999;Build 9
NAME ;ENTRY POINT FOR NAME
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
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
S AUPNNAMX=X
F AUPNII=$L(AUPNNAMX):-1:1 S:"/:;`*()_+=&%$#@![]{}|\?<>~"""[$E(AUPNNAMX,AUPNII) AUPNNAMX=$E(AUPNNAMX,1,AUPNII-1)_$E(AUPNNAMX,AUPNII+1,245)
I AUPNNAMX'=X K X
I $D(X) S X=$$UP^XLFSTR(X) ;IHS/ANMC/LJF 8/4/97 to convert to all caps
K AUPNNAMX,AUPNII
Q
PAT1109 ;EP
S PAT="PAT1109A" G QTM
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
PAT1109A S AUPNX=X S LKDA=DA,LKDR=1110,LKDIC=9000001,LKDRENT=0 D ^AUPNFMLK K:$D(LKERR) AUPNX Q
KILL K AUPNX,LKDATA,LKDENT,LKG,LKGL,LKPCC,LKPRINT Q
PAT1110 ;EP
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
PAT1110A S AUPNX=X S LKDA=DA,LKDR=1109,LKDIC=9000001,LKDRENT=0 D ^AUPNFMLK K:$D(LKERR) AUPNX Q
PAT4101 ;
Q:'$D(^AUPNPAT("D",X))
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
K AUPNPED("NXT"),AUPNPED("L")
Q
PAT4302 ;EP
S PAT="PAT4302A" G QTM
PAT4302A S AUPNX=X,(AUPNY,LKDA)=DA(1),LKDR=1110,LKDIC=9000001,LKDRENT=0 D ^AUPNFMLK K AUPNY K:$D(LKERR) AUPNX Q
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
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
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
PAT5101 ;EP
;IHS/OIT/LJF 02/28/2008 PATCH 19 fixed setting of LKDA variable
;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
S AUPNX=X S:$D(AUPNDOB) LKDATA=AUPNDOB G PAT5101A:$D(AUPNDOB) S LKDA=DA(1),LKDR=.03,LKDIC=2,LKDRENT=0 D ^AUPNFMLK G:$D(LKERR) PAT5101X
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
PAT5101B I LKDATA'="",$E(AUPNX,1,7)>LKDATA K AUPNX
PAT5101X S:$D(AUPNX) X=AUPNX K:'$D(AUPNX) X K LKDATA,LKDENT,LKG,LKGL,LKPCC,LKPRINT Q
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)
F LKI="H","MH","WH","WCH","PH","JA" K:LKI=LKPRINT&'(X?6N) X,LKI,AUPNX Q:'$D(AUPNX)
K LKI Q
RREPFX Q:X="" Q:'$D(^AUTTRRP(X)) S AUX=$P(^AUTTRRP(X,0),"^",1)
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="")
W *7,!,"This prefix requires that the number be 6 characters long.",!,"Change the number, then re-enter the prefix.",! K X
RREPFX1 K AUX G KILL
;
;
;INPUT TRANSFORM FOR E-MAIL FIELDS. CHECK FOR VALID E-MAIL ADDRESS
EMAIL ;EP - CHECK FOR VALID E-MAIL ADDRESS - CALLED FROM 9000001
N HOST,NAME
;CHECK FOR .EXT SHOULD BE 2 OR THREE CHARS AT THE END AFTER "."
S EXTENT=$P(X,".",$L(X,"."))
I $L(X)<3 K X Q ;MINIMUM IS X@X
I $L(X)>65 K X Q ;TOTAL LENGTH CANNOT EXCEED 65
I X'[("@") K X Q ;GENERAL PATTERN OF 'XXXX@XXXX'
I $L(X,"@")'=2 K X Q ;MUST HAVE JUST ONE "@"
S HOST=$P(X,"@",2)
S NAME=$P(X,"@")
;NAME MUST END IN ALPHA OR NUMERIC
I '($E(NAME,$L(NAME))?1A)&'($E(NAME,$L(NAME))?1N) K X Q
;HOST MUST BEGIN WITH ALPHA OR NUMERIC
I '($E(HOST)?1A)&'($E(HOST)?1N) K X Q
I HOST'[(".") K X Q
;THE FOLLOWING CHARACTER PAIRS ARE NOT ALLOWED
I X[(".-") K X Q
I X[("-.") K X Q
I X[("-.") K X Q
I X[("--") K X Q
I X[("..") K X Q
I X[("._") K X Q
I X[("-_") K X Q
I X[("_.") K X Q
I X[("_-") K X Q
I X[("__") K X Q
;THE FOLLOWING CHARACTERS ARE NOT ALLOWED
I X[(",") K X Q
I X[(";") K X Q
I X[(":") K X Q
I X[("(") K X Q
I X[(")") K X Q
I X[("=") K X Q
I X[("+") K X Q
I X[("!") K X Q
I X[("<") K X Q
I X[(">") K X Q
I X[("?") K X Q
I X[("/") K X Q
I X[("\") K X Q
Q
AUPNPED ; IHS/CMI/LAB - EDITS FOR PATIENT FILES ;
+1 ;;99.1;IHS DICTIONARIES (PATIENT);**18,19**;MAR 09, 1999;Build 9
NAME ;ENTRY POINT FOR NAME
+1 IF X[""""!(X'?1U.AP)!(X'[",")!(X?.E1","." ")!(X?.E1","." "1",".E)!($LENGTH(X,",")>3)!($LENGTH(X,".")>3)!($LENGTH(X,"-")>6)!($LENGTH(X,"(")>2)!($LENGTH(X,")")>2)!($LENGTH(X)>30)!($LENGTH(X)<3)!(X?.E1", ".E)
KILL X
QUIT
+2 FOR L=1:0
SET L=$FIND(X," ",L)
IF L=0
QUIT
IF $EXTRACT(X,L-2)?1P!($EXTRACT(X,L)?1P)!(L>$LENGTH(X))
SET X=$EXTRACT(X,1,L-2)_$EXTRACT(X,L,99)
SET L=L-1
+3 SET AUPNNAMX=X
+4 FOR AUPNII=$LENGTH(AUPNNAMX):-1:1
IF "/
SET AUPNNAMX=$EXTRACT(AUPNNAMX,1,AUPNII-1)_$EXTRACT(AUPNNAMX,AUPNII+1,245)
+5 IF AUPNNAMX'=X
KILL X
+6 ;IHS/ANMC/LJF 8/4/97 to convert to all caps
IF $DATA(X)
SET X=$$UP^XLFSTR(X)
+7 KILL AUPNNAMX,AUPNII
+8 QUIT
PAT1109 ;EP
+1 SET PAT="PAT1109A"
GOTO QTM
QTM DO QUANTUM
IF '$DATA(X)
QUIT
IF $EXTRACT(X,1,2)="UN"!(X="NONE")
QUIT
DO @PAT
IF '$DATA(AUPNX)
GOTO KILL
IF LKDATA="NONE"
KILL X
IF +LKDATA=0
GOTO KILL
IF X="FULL"
KILL X
IF '$DATA(X)
GOTO KILL
IF ($PIECE(X,"/",1)/$PIECE(X,"/",2))>($PIECE(LKDATA,"/",1)/$PIECE(LKDATA,"/",2))
KILL X
GOTO KILL
PAT1109A SET AUPNX=X
SET LKDA=DA
SET LKDR=1110
SET LKDIC=9000001
SET LKDRENT=0
DO ^AUPNFMLK
IF $DATA(LKERR)
KILL AUPNX
QUIT
KILL KILL AUPNX,LKDATA,LKDENT,LKG,LKGL,LKPCC,LKPRINT
QUIT
PAT1110 ;EP
+1 DO QUANTUM
IF '$DATA(X)
QUIT
IF $EXTRACT(X,1,2)="UN"!(X="FULL")
QUIT
DO PAT1110A
IF '$DATA(AUPNX)
GOTO KILL
IF LKDATA="FULL"
KILL X
IF +LKDATA=0
GOTO KILL
IF +X=0
KILL X
IF '$DATA(X)
GOTO KILL
IF ($PIECE(X,"/",1)/$PIECE(X,"/",2))<($PIECE(LKDATA,"/",1)/$PIECE(LKDATA,"/",2))
KILL X
GOTO KILL
PAT1110A SET AUPNX=X
SET LKDA=DA
SET LKDR=1109
SET LKDIC=9000001
SET LKDRENT=0
DO ^AUPNFMLK
IF $DATA(LKERR)
KILL AUPNX
QUIT
PAT4101 ;
+1 IF '$DATA(^AUPNPAT("D",X))
QUIT
+2 SET AUPNPED("NXT")=""
FOR AUPNPED("L")=0:0
SET AUPNPED("NXT")=$ORDER(^AUPNPAT("D",X,AUPNPED("NXT")))
IF AUPNPED("NXT")=""
QUIT
IF AUPNPED("NXT")'=DA(1)
IF $DATA(^AUPNPAT("D",X,AUPNPED("NXT"),DA))
WRITE " <Already used> "
KILL X
QUIT
+3 KILL AUPNPED("NXT"),AUPNPED("L")
+4 QUIT
PAT4302 ;EP
+1 SET PAT="PAT4302A"
GOTO QTM
PAT4302A SET AUPNX=X
SET (AUPNY,LKDA)=DA(1)
SET LKDR=1110
SET LKDIC=9000001
SET LKDRENT=0
DO ^AUPNFMLK
KILL AUPNY
IF $DATA(LKERR)
KILL AUPNX
QUIT
QUANTUM IF $LENGTH(X)>11!($LENGTH(X)<1)
KILL X
IF '$DATA(X)
QUIT
IF "NF"[$EXTRACT(X)
SET X=$SELECT($EXTRACT(X)="F":"FULL",1:"NONE")
QUIT
+1 IF $EXTRACT(X)'?1N&(($EXTRACT(X,1,3)'="UNK")&($EXTRACT(X,1,3)'="UNS"))
KILL X
IF '$DATA(X)
QUIT
IF $EXTRACT(X)="U"
SET X=$SELECT($EXTRACT(X,3)="K":"UNKNOWN",1:"UNSPECIFIED")
QUIT
+2 IF X'?1.4N1"/"1.5N
KILL X
IF '$DATA(X)
QUIT
IF $PIECE(X,"/",1)>$PIECE(X,"/",2)!(+$PIECE(X,"/",2)=0)
KILL X
IF '$DATA(X)
QUIT
IF $PIECE(X,"/",1)=$PIECE(X,"/",2)
SET X="FULL"
QUIT
PAT5101 ;EP
+1 ;IHS/OIT/LJF 02/28/2008 PATCH 19 fixed setting of LKDA variable
+2 ;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
+3 SET AUPNX=X
IF $DATA(AUPNDOB)
SET LKDATA=AUPNDOB
IF $DATA(AUPNDOB)
GOTO PAT5101A
SET LKDA=DA(1)
SET LKDR=.03
SET LKDIC=2
SET LKDRENT=0
DO ^AUPNFMLK
IF $DATA(LKERR)
GOTO PAT5101X
PAT5101A IF $EXTRACT(AUPNX,1,7)<LKDATA
KILL AUPNX
IF '$DATA(AUPNX)
GOTO PAT5101X
IF $DATA(AUPNDOD)
SET LKDATA=AUPNDOD
IF $DATA(AUPNDOD)
GOTO PAT5101B
SET LKDA=DA
SET LKDR=.351
SET LKDIC=2
SET LKDRENT=0
DO ^AUPNFMLK
IF $DATA(LKERR)
GOTO PAT5101X
PAT5101B IF LKDATA'=""
IF $EXTRACT(AUPNX,1,7)>LKDATA
KILL AUPNX
PAT5101X IF $DATA(AUPNX)
SET X=AUPNX
IF '$DATA(AUPNX)
KILL X
KILL LKDATA,LKDENT,LKG,LKGL,LKPCC,LKPRINT
QUIT
RRENUM IF '(X?6N)&'(X?9N)
KILL X
IF '$DATA(X)
QUIT
IF X?6N
QUIT
SET AUPNX=X
SET LKDA=DA
SET LKDR=.03
SET LKDIC=9000005
DO ^AUPNFMLK
IF '$DATA(LKPRINT)
KILL X,AUPNX
IF '$DATA(AUPNX)
QUIT
+1 FOR LKI="H","MH","WH","WCH","PH","JA"
IF LKI=LKPRINT&'(X?6N)
KILL X,LKI,AUPNX
IF '$DATA(AUPNX)
QUIT
+2 KILL LKI
QUIT
RREPFX IF X=""
QUIT
IF '$DATA(^AUTTRRP(X))
QUIT
SET AUX=$PIECE(^AUTTRRP(X,0),"^",1)
+1 IF '((AUX="H")!(AUX="MH")!(AUX="WH")!(AUX="WCH")!(AUX="PH")!(AUX="JA"))
GOTO RREPFX1
SET LKDA=DA
SET LKDR=.04
SET LKDIC=9000005
DO ^AUPNFMLK
IF '$DATA(LKPRINT)
QUIT
IF $LENGTH(LKPRINT)=6!(LKPRINT="")
QUIT
+2 WRITE *7,!,"This prefix requires that the number be 6 characters long.",!,"Change the number, then re-enter the prefix.",!
KILL X
RREPFX1 KILL AUX
GOTO KILL
+1 ;
+2 ;
+3 ;INPUT TRANSFORM FOR E-MAIL FIELDS. CHECK FOR VALID E-MAIL ADDRESS
EMAIL ;EP - CHECK FOR VALID E-MAIL ADDRESS - CALLED FROM 9000001
+1 NEW HOST,NAME
+2 ;CHECK FOR .EXT SHOULD BE 2 OR THREE CHARS AT THE END AFTER "."
+3 SET EXTENT=$PIECE(X,".",$LENGTH(X,"."))
+4 ;MINIMUM IS X@X
IF $LENGTH(X)<3
KILL X
QUIT
+5 ;TOTAL LENGTH CANNOT EXCEED 65
IF $LENGTH(X)>65
KILL X
QUIT
+6 ;GENERAL PATTERN OF 'XXXX@XXXX'
IF X'[("@")
KILL X
QUIT
+7 ;MUST HAVE JUST ONE "@"
IF $LENGTH(X,"@")'=2
KILL X
QUIT
+8 SET HOST=$PIECE(X,"@",2)
+9 SET NAME=$PIECE(X,"@")
+10 ;NAME MUST END IN ALPHA OR NUMERIC
+11 IF '($EXTRACT(NAME,$LENGTH(NAME))?1A)&'($EXTRACT(NAME,$LENGTH(NAME))?1N)
KILL X
QUIT
+12 ;HOST MUST BEGIN WITH ALPHA OR NUMERIC
+13 IF '($EXTRACT(HOST)?1A)&'($EXTRACT(HOST)?1N)
KILL X
QUIT
+14 IF HOST'[(".")
KILL X
QUIT
+15 ;THE FOLLOWING CHARACTER PAIRS ARE NOT ALLOWED
+16 IF X[(".-")
KILL X
QUIT
+17 IF X[("-.")
KILL X
QUIT
+18 IF X[("-.")
KILL X
QUIT
+19 IF X[("--")
KILL X
QUIT
+20 IF X[("..")
KILL X
QUIT
+21 IF X[("._")
KILL X
QUIT
+22 IF X[("-_")
KILL X
QUIT
+23 IF X[("_.")
KILL X
QUIT
+24 IF X[("_-")
KILL X
QUIT
+25 IF X[("__")
KILL X
QUIT
+26 ;THE FOLLOWING CHARACTERS ARE NOT ALLOWED
+27 IF X[(",")
KILL X
QUIT
+28 IF X[(";")
KILL X
QUIT
+29 IF X[(":")
KILL X
QUIT
+30 IF X[("(")
KILL X
QUIT
+31 IF X[(")")
KILL X
QUIT
+32 IF X[("=")
KILL X
QUIT
+33 IF X[("+")
KILL X
QUIT
+34 IF X[("!")
KILL X
QUIT
+35 IF X[("<")
KILL X
QUIT
+36 IF X[(">")
KILL X
QUIT
+37 IF X[("?")
KILL X
QUIT
+38 IF X[("/")
KILL X
QUIT
+39 IF X[("\")
KILL X
QUIT
+40 QUIT
