- DGPT10CB ;ALB/MTC - Edit checks for Cat of Ben ; 12 NOV 92
- ;;5.3;Registration;**234,466,1015**;Aug 13, 1993;Build 21
- ;;
- 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
- DGPT10CB ;ALB/MTC - Edit checks for Cat of Ben ; 12 NOV 92
- +1 ;;5.3;Registration;**234,466,1015**;Aug 13, 1993;Build 21
- +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
