DGRPDD1 ;ALB/JDS,LBD - INPUT SYNTAX CHECKS - FORMERLY DGINP ; 1/28/13 9:50am
;;5.3;Registration;**72,136,244,621,797,866**;AUG 13, 1993;Build 9
;
; NOTE: THIS USED TO BE NAMED 'DGINP'
; -----
;
INPUT ; from 7.5 node to massage input before input transform
I X?.N1"/"1N.ANP D BCDFN^RTDPA Q ; check for RT label scan
Q
;
SSN I X'?.AN F %=1:1:$L(X) I $E(X,%)?1P S X=$E(X,0,%-1)_$E(X,%+1,999),%=%-1
I X="P"!(X="p") D PSEU S X=L K L W:'$D(ZTQUEUED) " ",X G SSNQ
I X["P",'$D(DPTZNV) D PSEU I X'=L K X,L W:'$D(ZTQUEUED) *7," Invalid pseudo SSN.",!,"Type 'P' for the valid one" Q
I X["P",$D(DPTZNV) D PSEU I X'=L S X=L W:'$D(ZTQUEUED) !!,$C(7),"Pseudo SSN adjusted to match edited name value ==> ",X,!
G SSNQ:X["P" I X'?9N K X Q
I $G(DIUTIL)'="VERIFY FIELDS" S DGY=$O(^DPT("SSN",X,0)) I DGY>0,$D(^DPT(DGY,0)) W:'$D(ZTQUEUED) *7," Already used by patient '",$P(^(0),"^",1),"'." K X Q
I $D(X) S L=$E(X,1) I L=9 W:'$D(ZTQUEUED) *7,!," The SSN must not begin with 9." K X Q
I $D(X),$E(X,1,3)="000",$E(X,1,5)'="00000" W:'$D(ZTQUEUED) *7,!," First three digits cannot be zeros." K X Q
I $D(X) S L=$E(X,1,3) I (L>699)&(L<729) W:'$D(ZTQUEUED) !,*7,!," Note: This is a RR Retirement SSN."
I $D(X),$E(X,1,5)="00000" W:'$D(ZTQUEUED) !,*7,!," Note: This is a Test Patient SSN."
SSNQ D:$D(X) S^DGPATN Q
C I $D(X) S L=$P(^DPT(DA,0),U,9) I $L(L)=9,X'=L S Y=L_"00" D COL
K L Q:'$D(X) Q:X'?11N!(X["P") S L=0 F Y=0:0 S Y=$O(^DPT("BS",$E(X,6,9),Y)) Q:Y'>0 I Y-DA,$D(^DPT(Y,0)),$P(^(0),U,9)=$E(X,1,9) S L=1 Q
I L W:'$D(ZTQUEUED) " Collateral of ",$P(^DPT(Y,0),U,1) K L Q
W:'$D(ZTQUEUED) !,"Must have same SSN to be collateral" K X,L Q
PSEU I $D(DPTIDS(.03)),$D(DPTX) S NAM=DPTX,DOB=DPTIDS(.03)
E S L=^DPT(DA,0),DOB=$P(L,"^",3),NAM=$P(L,"^",1)
; DG*5.3*621
I DOB="" S DOB=2000000
S L1=$E($P(NAM," ",2),1),L3=$E(NAM,1),NAM=$P(NAM,",",2),L2=$E(NAM,1)
S Z=L1 D CON S L1=Z,Z=L2 D CON S L2=Z,Z=L3 D CON S L3=Z S L=L2_L1_L3_$E(DOB,4,7)_$E(DOB,2,3)_"P"
I $D(^DPT("SSN",L)) S L=$$CHECK(L)
K L1,L2,L3,Z,DOB,NAM Q
CHECK(PSSN) ;patch DG*5.3*866 no duplicate pseudo ssn's
F Q:'$D(^DPT("SSN",PSSN)) S PSSN=(PSSN+1)_"P"
Q PSSN
COL S Y=$O(^DPT("SSN",Y)) Q:$E(Y,1,9)'=L I $L(Y)=11,$E(Y,1,9)=L S Z=$O(^(Y,0)) I $D(^DPT(Z,0)) W:'$D(ZTQUEUED) !,"Has collateral ",$P(^(0),U,1)," be sure to change SSN" K Z G COL
Q
CON S Z=$A(Z)-65\3+1 S:Z<0 Z=0 Q
;
CAT S L=^DPT(DA,0),DOB=+$P(L,"^",3),AGE=DT-DOB\10000,X1=^DIC(45.82,+Y,0),EDB=+$P(X1,U,4),LDB=+$P(X1,U,5),EAG=+$P(X1,U,6)
I EDB>0,DOB<EDB W:'$D(ZTQUEUED) !!,"The date of birth is too early for the selected category of beneficiary",!,"Make another selection or correct the date of birth.",!!,*7 K X G CATQ
I LDB>0,DOB>LDB W:'$D(ZTQUEUED) !!,"The date of birth is too late for the selected category of beneficiary.",!,"Make another selection or correct the date of birth.",!!,*7 K X G CATQ
I EAG>0,AGE<EAG W:'$D(ZTQUEUED) !!,"The patient's age is too young for the selected category of beneficiary.",!,"Make another selection or correct the date of birth.",!!,*7 K X G CATQ
CATQ K EAG,AGE,DOB,LDB,EDB,X1 Q
;
VIET Q
POS S L=^DPT(DA,0),Y=+$P(L,"^",3) I X-Y\10000<15 X ^DD("DD") W:'$D(ZTQUEUED) !!,"This service entry date would make the patient too young for service.",!,"DOB ",Y,!,*7 K X G POSQ
G POSQ:SD1=1!'$D(^DPT(DA,.32)) S L1=^(.32) I $P(L1,"^",SD1-1*5+1)="" W:'$D(ZTQUEUED) !?5,"Previous service entry date is not on file",*7 G POSQ
S Y=$P(L1,U,6) I SD1=2,X'<Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"This service entry date must be before than the first service entry date ",Y,!!,*7 K X G POSQ
S Y=$P(L1,U,11) I SD1=3,X'<Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"This service entry date must be less than the second service entry date ",Y,!!,*7 K X G POSQ
POSQ K L1,L,DOB,AGE,SD1 Q
;
PS S L1=$S($D(^DPT(DA,.32)):^(.32),1:"") G PS2:SD1=2,PS3:SD1=3 S Y=$P(L1,U,6) I X'>Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"The service separation date must be after the entry date ",Y,!!,*7 K X G PSQ
;
G PSQ
PS2 S Y=$P(L1,U,11) I X'>Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"The service separation date must be after the service entry date ",Y,!!,*7 K X G PSQ
S Y=$P(L1,U,6) I Y,X'<Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"This service separation date must be before the next service entry date ",Y,!!,*7 K X G PSQ
G PSQ
PS3 S Y=$P(L1,U,16) I X'>Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"The service separation date must be after the service entry date ",Y,!!,*7 K X G PSQ
S Y=$P(L1,U,11) I X'<Y X ^DD("DD") W:'$D(ZTQUEUED) !!,"The service separation date must be before the next service entry date ",Y,!!,*7 K X G POSQ
PSQ K L1,SD1 Q
CAT1 S DDA=DA,DA=+^DGPT(DA,0) D CAT S DA=DDA K DDA Q
;
AGE(DFN,X) ;Called from input transform of SERVICE ENTRY field (#.01) of the
;MILITARY SERVICE EPISODE sub-file #2.3216. Added for DG*5.3*797.
N DOB,MSG
Q:'$G(DFN) 0 Q:'$G(X) 0
S DOB=+$P($G(^DPT(DFN,0)),U,3)
I X-DOB\10000<15 D Q 0
.S MSG(1)="This service entry date would make the patient too young for service."
.S MSG(1,"F")="!!"
.S MSG(2)="DOB "_$$FMTE^XLFDT(DOB)
.D EN^DDIOL(.MSG)
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPDD1 5107 printed Sep 23, 2025@20:32:06 Page 2
DGRPDD1 ;ALB/JDS,LBD - INPUT SYNTAX CHECKS - FORMERLY DGINP ; 1/28/13 9:50am
+1 ;;5.3;Registration;**72,136,244,621,797,866**;AUG 13, 1993;Build 9
+2 ;
+3 ; NOTE: THIS USED TO BE NAMED 'DGINP'
+4 ; -----
+5 ;
INPUT ; from 7.5 node to massage input before input transform
+1 ; check for RT label scan
IF X?.N1"/"1N.ANP
DO BCDFN^RTDPA
QUIT
+2 QUIT
+3 ;
SSN IF X'?.AN
FOR %=1:1:$LENGTH(X)
IF $EXTRACT(X,%)?1P
SET X=$EXTRACT(X,0,%-1)_$EXTRACT(X,%+1,999)
SET %=%-1
+1 IF X="P"!(X="p")
DO PSEU
SET X=L
KILL L
if '$DATA(ZTQUEUED)
WRITE " ",X
GOTO SSNQ
+2 IF X["P"
IF '$DATA(DPTZNV)
DO PSEU
IF X'=L
KILL X,L
if '$DATA(ZTQUEUED)
WRITE *7," Invalid pseudo SSN.",!,"Type 'P' for the valid one"
QUIT
+3 IF X["P"
IF $DATA(DPTZNV)
DO PSEU
IF X'=L
SET X=L
if '$DATA(ZTQUEUED)
WRITE !!,$CHAR(7),"Pseudo SSN adjusted to match edited name value ==> ",X,!
+4 if X["P"
GOTO SSNQ
IF X'?9N
KILL X
QUIT
+5 IF $GET(DIUTIL)'="VERIFY FIELDS"
SET DGY=$ORDER(^DPT("SSN",X,0))
IF DGY>0
IF $DATA(^DPT(DGY,0))
if '$DATA(ZTQUEUED)
WRITE *7," Already used by patient '",$PIECE(^(0),"^",1),"'."
KILL X
QUIT
+6 IF $DATA(X)
SET L=$EXTRACT(X,1)
IF L=9
if '$DATA(ZTQUEUED)
WRITE *7,!," The SSN must not begin with 9."
KILL X
QUIT
+7 IF $DATA(X)
IF $EXTRACT(X,1,3)="000"
IF $EXTRACT(X,1,5)'="00000"
if '$DATA(ZTQUEUED)
WRITE *7,!," First three digits cannot be zeros."
KILL X
QUIT
+8 IF $DATA(X)
SET L=$EXTRACT(X,1,3)
IF (L>699)&(L<729)
if '$DATA(ZTQUEUED)
WRITE !,*7,!," Note: This is a RR Retirement SSN."
+9 IF $DATA(X)
IF $EXTRACT(X,1,5)="00000"
if '$DATA(ZTQUEUED)
WRITE !,*7,!," Note: This is a Test Patient SSN."
SSNQ if $DATA(X)
DO S^DGPATN
QUIT
C IF $DATA(X)
SET L=$PIECE(^DPT(DA,0),U,9)
IF $LENGTH(L)=9
IF X'=L
SET Y=L_"00"
DO COL
+1 KILL L
if '$DATA(X)
QUIT
if X'?11N!(X["P")
QUIT
SET L=0
FOR Y=0:0
SET Y=$ORDER(^DPT("BS",$EXTRACT(X,6,9),Y))
if Y'>0
QUIT
IF Y-DA
IF $DATA(^DPT(Y,0))
IF $PIECE(^(0),U,9)=$EXTRACT(X,1,9)
SET L=1
QUIT
+2 IF L
if '$DATA(ZTQUEUED)
WRITE " Collateral of ",$PIECE(^DPT(Y,0),U,1)
KILL L
QUIT
+3 if '$DATA(ZTQUEUED)
WRITE !,"Must have same SSN to be collateral"
KILL X,L
QUIT
PSEU IF $DATA(DPTIDS(.03))
IF $DATA(DPTX)
SET NAM=DPTX
SET DOB=DPTIDS(.03)
+1 IF '$TEST
SET L=^DPT(DA,0)
SET DOB=$PIECE(L,"^",3)
SET NAM=$PIECE(L,"^",1)
+2 ; DG*5.3*621
+3 IF DOB=""
SET DOB=2000000
+4 SET L1=$EXTRACT($PIECE(NAM," ",2),1)
SET L3=$EXTRACT(NAM,1)
SET NAM=$PIECE(NAM,",",2)
SET L2=$EXTRACT(NAM,1)
+5 SET Z=L1
DO CON
SET L1=Z
SET Z=L2
DO CON
SET L2=Z
SET Z=L3
DO CON
SET L3=Z
SET L=L2_L1_L3_$EXTRACT(DOB,4,7)_$EXTRACT(DOB,2,3)_"P"
+6 IF $DATA(^DPT("SSN",L))
SET L=$$CHECK(L)
+7 KILL L1,L2,L3,Z,DOB,NAM
QUIT
CHECK(PSSN) ;patch DG*5.3*866 no duplicate pseudo ssn's
+1 FOR
if '$DATA(^DPT("SSN",PSSN))
QUIT
SET PSSN=(PSSN+1)_"P"
+2 QUIT PSSN
COL SET Y=$ORDER(^DPT("SSN",Y))
if $EXTRACT(Y,1,9)'=L
QUIT
IF $LENGTH(Y)=11
IF $EXTRACT(Y,1,9)=L
SET Z=$ORDER(^(Y,0))
IF $DATA(^DPT(Z,0))
if '$DATA(ZTQUEUED)
WRITE !,"Has collateral ",$PIECE(^(0),U,1)," be sure to change SSN"
KILL Z
GOTO COL
+1 QUIT
CON SET Z=$ASCII(Z)-65\3+1
if Z<0
SET Z=0
QUIT
+1 ;
CAT SET L=^DPT(DA,0)
SET DOB=+$PIECE(L,"^",3)
SET AGE=DT-DOB\10000
SET X1=^DIC(45.82,+Y,0)
SET EDB=+$PIECE(X1,U,4)
SET LDB=+$PIECE(X1,U,5)
SET EAG=+$PIECE(X1,U,6)
+1 IF EDB>0
IF DOB<EDB
if '$DATA(ZTQUEUED)
WRITE !!,"The date of birth is too early for the selected category of beneficiary",!,"Make another selection or correct the date of birth.",!!,*7
KILL X
GOTO CATQ
+2 IF LDB>0
IF DOB>LDB
if '$DATA(ZTQUEUED)
WRITE !!,"The date of birth is too late for the selected category of beneficiary.",!,"Make another selection or correct the date of birth.",!!,*7
KILL X
GOTO CATQ
+3 IF EAG>0
IF AGE<EAG
if '$DATA(ZTQUEUED)
WRITE !!,"The patient's age is too young for the selected category of beneficiary.",!,"Make another selection or correct the date of birth.",!!,*7
KILL X
GOTO CATQ
CATQ KILL EAG,AGE,DOB,LDB,EDB,X1
QUIT
+1 ;
VIET QUIT
POS SET L=^DPT(DA,0)
SET Y=+$PIECE(L,"^",3)
IF X-Y\10000<15
XECUTE ^DD("DD")
if '$DATA(ZTQUEUED)
WRITE !!,"This service entry date would make the patient too young for service.",!,"DOB ",Y,!,*7
KILL X
GOTO POSQ
+1 if SD1=1!'$DATA(^DPT(DA,.32))
GOTO POSQ
SET L1=^(.32)
IF $PIECE(L1,"^",SD1-1*5+1)=""
if '$DATA(ZTQUEUED)
WRITE !?5,"Previous service entry date is not on file",*7
GOTO POSQ
+2 SET Y=$PIECE(L1,U,6)
IF SD1=2
IF X'<Y
XECUTE ^DD("DD")
if '$DATA(ZTQUEUED)
WRITE !!,"This service entry date must be before than the first service entry date ",Y,!!,*7
KILL X
GOTO POSQ
+3 SET Y=$PIECE(L1,U,11)
IF SD1=3
IF X'<Y
XECUTE ^DD("DD")
if '$DATA(ZTQUEUED)
WRITE !!,"This service entry date must be less than the second service entry date ",Y,!!,*7
KILL X
GOTO POSQ
POSQ KILL L1,L,DOB,AGE,SD1
QUIT
+1 ;
PS SET L1=$SELECT($DATA(^DPT(DA,.32)):^(.32),1:"")
if SD1=2
GOTO PS2
if SD1=3
GOTO PS3
SET Y=$PIECE(L1,U,6)
IF X'>Y
XECUTE ^DD("DD")
if '$DATA(ZTQUEUED)
WRITE !!,"The service separation date must be after the entry date ",Y,!!,*7
KILL X
GOTO PSQ
+1 ;
+2 GOTO PSQ
PS2 SET Y=$PIECE(L1,U,11)
IF X'>Y
XECUTE ^DD("DD")
if '$DATA(ZTQUEUED)
WRITE !!,"The service separation date must be after the service entry date ",Y,!!,*7
KILL X
GOTO PSQ
+1 SET Y=$PIECE(L1,U,6)
IF Y
IF X'<Y
XECUTE ^DD("DD")
if '$DATA(ZTQUEUED)
WRITE !!,"This service separation date must be before the next service entry date ",Y,!!,*7
KILL X
GOTO PSQ
+2 GOTO PSQ
PS3 SET Y=$PIECE(L1,U,16)
IF X'>Y
XECUTE ^DD("DD")
if '$DATA(ZTQUEUED)
WRITE !!,"The service separation date must be after the service entry date ",Y,!!,*7
KILL X
GOTO PSQ
+1 SET Y=$PIECE(L1,U,11)
IF X'<Y
XECUTE ^DD("DD")
if '$DATA(ZTQUEUED)
WRITE !!,"The service separation date must be before the next service entry date ",Y,!!,*7
KILL X
GOTO POSQ
PSQ KILL L1,SD1
QUIT
CAT1 SET DDA=DA
SET DA=+^DGPT(DA,0)
DO CAT
SET DA=DDA
KILL DDA
QUIT
+1 ;
AGE(DFN,X) ;Called from input transform of SERVICE ENTRY field (#.01) of the
+1 ;MILITARY SERVICE EPISODE sub-file #2.3216. Added for DG*5.3*797.
+2 NEW DOB,MSG
+3 if '$GET(DFN)
QUIT 0
if '$GET(X)
QUIT 0
+4 SET DOB=+$PIECE($GET(^DPT(DFN,0)),U,3)
+5 IF X-DOB\10000<15
Begin DoDot:1
+6 SET MSG(1)="This service entry date would make the patient too young for service."
+7 SET MSG(1,"F")="!!"
+8 SET MSG(2)="DOB "_$$FMTE^XLFDT(DOB)
+9 DO EN^DDIOL(.MSG)
End DoDot:1
QUIT 0
+10 QUIT 1
