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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPT10CB 1705 printed Sep 23, 2025@20:27:07 Page 2
DGPT10CB ;ALB/MTC - Edit checks for Cat of Ben ; 12 NOV 92
+1 ;;5.3;Registration;**234,466**;Aug 13, 1993
+2 ;;
SET ;
+1 IF ((DGPTPOS2'?1U)&(DGPTPOS2'?1N))
SET DGPTERC=114
QUIT
+2 IF "89MNPQRSTUX"[DGPTPOS2
QUIT
+3 SET DGPTBYR=$EXTRACT(DGPTDOB,5,8)
+4 IF "6ABCDEFGHJKL"[DGPTPOS2
DO ONE
QUIT
+5 IF DGPTPOS2="Z"
DO MT
if DGPTERC
QUIT
DO POW
if DGPTERC
QUIT
+6 IF "V0123457WYZ"'[DGPTPOS2
SET DGPTERC=114
QUIT
+7 DO @DGPTPOS2
QUIT
3 ;
+1 IF ((DGPTBYR<1870)!(DGPTBYR>1936))
SET DGPTERC=132
QUIT
+2 QUIT
1 ;
+1 IF ((DGPTBYR<1870)!(DGPTBYR>1904))
SET DGPTERC=132
QUIT
+2 IF ((+DGPTDTS)<2170406)
SET DGPTERC=131
QUIT
+3 QUIT
2 ;
+1 IF ((DGPTBYR<1871)!(DGPTBYR>1932))
SET DGPTERC=132
QUIT
+2 IF ((+DGPTDTS)<2411207)
SET DGPTERC=131
QUIT
+3 QUIT
4 ;
+1 IF ((DGPTBYR<1870)!(DGPTBYR>1936))
SET DGPTERC=132
QUIT
+2 QUIT
0 ;
+1 IF ((DGPTBYR<1880)!(DGPTBYR>1941))
SET DGPTERC=132
QUIT
+2 IF ((+DGPTDTS)<2500627)
SET DGPTERC=131
QUIT
+3 QUIT
5 ;
+1 IF ((DGPTBYR<1885)!(DGPTBYR>1950))
SET DGPTERC=132
QUIT
+2 IF ((+DGPTDTS)<2550201)
SET DGPTERC=131
QUIT
+3 QUIT
7 ;
+1 IF ((DGPTBYR<1894)!(DGPTBYR>1961))
SET DGPTERC=132
QUIT
+2 IF ((+DGPTDTS)<2640805)
SET DGPTERC=131
QUIT
+3 QUIT
V ;
+1 NEW LIEN,MIEN
SET (LIEN,MIEN)=""
+2 SET LIEN=$PIECE($GET(VAEL(1)),U)
+3 IF $GET(LIEN)'=""
SET MIEN=$PIECE($GET(^DIC(8,LIEN,0)),U,9)
+4 IF MIEN'=19
SET DGPTERC=114
+5 QUIT
W ;
+1 IF ((DGPTBYR<1871)!(DGPTBYR>1932))
SET DGPTERC=132
QUIT
+2 IF ((+DGPTDTS)<2411207)
SET DGPTERC=131
QUIT
+3 QUIT
Y ;
+1 IF ((+DGPTDTS)<2860930)
SET DGPTERC=131
QUIT
+2 QUIT
Z ;
+1 IF ((DGPTBYR<1871)!(DGPTBYR>1932))
SET DGPTERC=132
QUIT
+2 IF ((+DGPTDTS)<2880119)
SET DGPTERC=131
QUIT
+3 QUIT
ONE ;
+1 IF DGPTAGE<14
SET DGPTERC=132
QUIT
+2 QUIT
MT ;
+1 if DGPTPOS2'="Z"
QUIT
+2 IF "ABCGUX"'[$EXTRACT(DGPTMTC,1)
SET DGPTERC=119
QUIT
+3 IF $EXTRACT(DGPTMTC,1)="A"&("SN"'[$EXTRACT(DGPTMTC,2))
SET DGPTERC=119
QUIT
+4 IF "BCGUX"[$EXTRACT(DGPTMTC,1)&($EXTRACT(DGPTMTC,2)'=" ")
SET DGPTERC=119
QUIT
+5 QUIT
POW ;
+1 if DGPTPOS2'="Z"
QUIT
+2 IF "1234"'[DGPTPOW
SET DGPTERC=110
QUIT
+3 QUIT
