68 lines
1.6 KiB
Mathematica
68 lines
1.6 KiB
Mathematica
DGPT10CB ;ALB/MTC - Edit checks for Cat of Ben ; 12 NOV 92
|
|
;;5.3;Registration;**234,466**;Aug 13, 1993
|
|
;;
|
|
SET ;
|
|
I ((DGPTPOS2'?1U)&(DGPTPOS2'?1N)) S DGPTERC=114 Q
|
|
I "89MNPQRSTUX"[DGPTPOS2 Q
|
|
S DGPTBYR=$E(DGPTDOB,5,8)
|
|
I "6ABCDEFGHJKL"[DGPTPOS2 D ONE Q
|
|
I DGPTPOS2="Z" D MT Q:DGPTERC D POW Q:DGPTERC
|
|
I "V0123457WYZ"'[DGPTPOS2 S DGPTERC=114 Q
|
|
D @DGPTPOS2 Q
|
|
3 ;
|
|
I ((DGPTBYR<1870)!(DGPTBYR>1936)) S DGPTERC=132 Q
|
|
Q
|
|
1 ;
|
|
I ((DGPTBYR<1870)!(DGPTBYR>1904)) S DGPTERC=132 Q
|
|
I ((+DGPTDTS)<2170406) S DGPTERC=131 Q
|
|
Q
|
|
2 ;
|
|
I ((DGPTBYR<1871)!(DGPTBYR>1932)) S DGPTERC=132 Q
|
|
I ((+DGPTDTS)<2411207) S DGPTERC=131 Q
|
|
Q
|
|
4 ;
|
|
I ((DGPTBYR<1870)!(DGPTBYR>1936)) S DGPTERC=132 Q
|
|
Q
|
|
0 ;
|
|
I ((DGPTBYR<1880)!(DGPTBYR>1941)) S DGPTERC=132 Q
|
|
I ((+DGPTDTS)<2500627) S DGPTERC=131 Q
|
|
Q
|
|
5 ;
|
|
I ((DGPTBYR<1885)!(DGPTBYR>1950)) S DGPTERC=132 Q
|
|
I ((+DGPTDTS)<2550201) S DGPTERC=131 Q
|
|
Q
|
|
7 ;
|
|
I ((DGPTBYR<1894)!(DGPTBYR>1961)) S DGPTERC=132 Q
|
|
I ((+DGPTDTS)<2640805) S DGPTERC=131 Q
|
|
Q
|
|
V ;
|
|
N LIEN,MIEN S (LIEN,MIEN)=""
|
|
S LIEN=$P($G(VAEL(1)),U)
|
|
I $G(LIEN)'="" S MIEN=$P($G(^DIC(8,LIEN,0)),U,9)
|
|
I MIEN'=19 S DGPTERC=114
|
|
Q
|
|
W ;
|
|
I ((DGPTBYR<1871)!(DGPTBYR>1932)) S DGPTERC=132 Q
|
|
I ((+DGPTDTS)<2411207) S DGPTERC=131 Q
|
|
Q
|
|
Y ;
|
|
I ((+DGPTDTS)<2860930) S DGPTERC=131 Q
|
|
Q
|
|
Z ;
|
|
I ((DGPTBYR<1871)!(DGPTBYR>1932)) S DGPTERC=132 Q
|
|
I ((+DGPTDTS)<2880119) S DGPTERC=131 Q
|
|
Q
|
|
ONE ;
|
|
I DGPTAGE<14 S DGPTERC=132 Q
|
|
Q
|
|
MT ;
|
|
Q:DGPTPOS2'="Z"
|
|
I "ABCGUX"'[$E(DGPTMTC,1) S DGPTERC=119 Q
|
|
I $E(DGPTMTC,1)="A"&("SN"'[$E(DGPTMTC,2)) S DGPTERC=119 Q
|
|
I "BCGUX"[$E(DGPTMTC,1)&($E(DGPTMTC,2)'=" ") S DGPTERC=119 Q
|
|
Q
|
|
POW ;
|
|
Q:DGPTPOS2'="Z"
|
|
I "1234"'[DGPTPOW S DGPTERC=110 Q
|
|
Q
|