Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AUPNPED

AUPNPED.m

Go to the documentation of this file. 
  1. AUPNPED ; IHS/CMI/LAB - EDITS FOR PATIENT FILES ;
  1.  ;;99.1;IHS DICTIONARIES (PATIENT);**18,19**;MAR 09, 1999;Build 9
  1. NAME ;ENTRY POINT FOR NAME
  1.  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
  1.  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
  1.  S AUPNNAMX=X
  1.  F AUPNII=$L(AUPNNAMX):-1:1 S:"/:;`*()_+=&%$#@![]{}|\?<>~"""[$E(AUPNNAMX,AUPNII) AUPNNAMX=$E(AUPNNAMX,1,AUPNII-1)_$E(AUPNNAMX,AUPNII+1,245)
  1.  I AUPNNAMX'=X K X
  1.  I $D(X) S X=$$UP^XLFSTR(X)  ;IHS/ANMC/LJF 8/4/97 to convert to all caps
  1.  K AUPNNAMX,AUPNII
  1.  Q
  1. PAT1109 ;EP
  1.  S PAT="PAT1109A" G QTM
  1. 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
  1. PAT1109A S AUPNX=X S LKDA=DA,LKDR=1110,LKDIC=9000001,LKDRENT=0 D ^AUPNFMLK K:$D(LKERR) AUPNX Q
  1. KILL K AUPNX,LKDATA,LKDENT,LKG,LKGL,LKPCC,LKPRINT Q
  1. PAT1110 ;EP
  1.  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
  1. PAT1110A S AUPNX=X S LKDA=DA,LKDR=1109,LKDIC=9000001,LKDRENT=0 D ^AUPNFMLK K:$D(LKERR) AUPNX Q
  1. PAT4101 ;
  1.  Q:'$D(^AUPNPAT("D",X))
  1.  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
  1.  K AUPNPED("NXT"),AUPNPED("L")
  1.  Q
  1. PAT4302 ;EP
  1.  S PAT="PAT4302A" G QTM
  1. PAT4302A S AUPNX=X,(AUPNY,LKDA)=DA(1),LKDR=1110,LKDIC=9000001,LKDRENT=0 D ^AUPNFMLK K AUPNY K:$D(LKERR) AUPNX Q
  1. 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
  1.  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
  1.  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
  1. PAT5101 ;EP
  1.  ;IHS/OIT/LJF 02/28/2008 PATCH 19 fixed setting of LKDA variable
  1.  ;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
  1.  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
  1. 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
  1. PAT5101B I LKDATA'="",$E(AUPNX,1,7)>LKDATA K AUPNX
  1. PAT5101X S:$D(AUPNX) X=AUPNX K:'$D(AUPNX) X K LKDATA,LKDENT,LKG,LKGL,LKPCC,LKPRINT Q
  1. 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)
  1.  F LKI="H","MH","WH","WCH","PH","JA" K:LKI=LKPRINT&'(X?6N) X,LKI,AUPNX Q:'$D(AUPNX)
  1.  K LKI Q
  1. RREPFX Q:X=""  Q:'$D(^AUTTRRP(X))  S AUX=$P(^AUTTRRP(X,0),"^",1)
  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="")
  1.  W *7,!,"This prefix requires that the number be 6 characters long.",!,"Change the number, then re-enter the prefix.",! K X
  1. RREPFX1 K AUX G KILL
  1.  ;
  1.  ;
  1.   ;INPUT TRANSFORM FOR E-MAIL FIELDS. CHECK FOR VALID E-MAIL ADDRESS
  1. EMAIL ;EP - CHECK FOR VALID E-MAIL ADDRESS - CALLED FROM 9000001
  1.  N HOST,NAME
  1.  ;CHECK FOR .EXT SHOULD BE 2 OR THREE CHARS AT THE END AFTER "."
  1.  S EXTENT=$P(X,".",$L(X,"."))
  1.  I $L(X)<3 K X Q            ;MINIMUM IS X@X
  1.  I $L(X)>65 K X Q           ;TOTAL LENGTH CANNOT EXCEED 65
  1.  I X'[("@") K X Q      ;GENERAL PATTERN OF 'XXXX@XXXX'
  1.  I $L(X,"@")'=2 K X Q   ;MUST HAVE JUST ONE "@"
  1.  S HOST=$P(X,"@",2)
  1.  S NAME=$P(X,"@")
  1.  ;NAME MUST END IN ALPHA OR NUMERIC
  1.  I '($E(NAME,$L(NAME))?1A)&'($E(NAME,$L(NAME))?1N) K X Q
  1.  ;HOST MUST BEGIN WITH ALPHA OR NUMERIC
  1.  I '($E(HOST)?1A)&'($E(HOST)?1N) K X Q
  1.  I HOST'[(".") K X Q
  1.  ;THE FOLLOWING CHARACTER PAIRS ARE NOT ALLOWED
  1.  I X[(".-") K X Q
  1.  I X[("-.") K X Q
  1.  I X[("-.") K X Q
  1.  I X[("--") K X Q
  1.  I X[("..") K X Q
  1.  I X[("._") K X Q
  1.  I X[("-_") K X Q
  1.  I X[("_.") K X Q
  1.  I X[("_-") K X Q
  1.  I X[("__") K X Q
  1.  ;THE FOLLOWING CHARACTERS ARE NOT ALLOWED
  1.  I X[(",") K X Q
  1.  I X[(";") K X Q
  1.  I X[(":") K X Q
  1.  I X[("(") K X Q
  1.  I X[(")") K X Q
  1.  I X[("=") K X Q
  1.  I X[("+") K X Q
  1.  I X[("!") K X Q
  1.  I X[("<") K X Q
  1.  I X[(">") K X Q
  1.  I X[("?") K X Q
  1.  I X[("/") K X Q
  1.  I X[("\") K X Q
  1.  Q