DGRPDD1 ;ALB/JDS - INPUT SYNTAX CHECKS - FORMERLY DGINP ; 9/23/04 6:04pm
;;5.3;Registration;**72,136,244,621,1015**;AUG 13, 1993;Build 21
;
;IHS/ANMC/LJF 8/14/2001 changed variables in PSEU since may be
; called on add new patient where DA=0
; 11/14/2001 bypass RT label scan check
;
; NOTE: THIS USED TO BE NAMED 'DGINP'
; -----
;
INPUT ; from 7.5 node to massage input before input transform
Q ;IHS/ANMC/LJF 11/14/2001
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) ;IHS/ANMC/LJF 8/14/2001
I $D(AUPIDS(.03)),$D(AUPX) S NAM=AUPX,DOB=AUPIDS(.03) ;IHS/ANMC/LJF 8/14/2001 added because DA set to 0 on new add when this is called
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"
K L1,L2,L3,Z,DOB,NAM Q
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
DGRPDD1 ;ALB/JDS - INPUT SYNTAX CHECKS - FORMERLY DGINP ; 9/23/04 6:04pm
+1 ;;5.3;Registration;**72,136,244,621,1015**;AUG 13, 1993;Build 21
+2 ;
+3 ;IHS/ANMC/LJF 8/14/2001 changed variables in PSEU since may be
+4 ; called on add new patient where DA=0
+5 ; 11/14/2001 bypass RT label scan check
+6 ;
+7 ; NOTE: THIS USED TO BE NAMED 'DGINP'
+8 ; -----
+9 ;
INPUT ; from 7.5 node to massage input before input transform
+1 ;IHS/ANMC/LJF 11/14/2001
QUIT
+2 ; check for RT label scan
IF X?.N1"/"1N.ANP
DO BCDFN^RTDPA
QUIT
+3 QUIT
+4 ;
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 ;I $D(DPTIDS(.03)),$D(DPTX) S NAM=DPTX,DOB=DPTIDS(.03) ;IHS/ANMC/LJF 8/14/2001
+1 ;IHS/ANMC/LJF 8/14/2001 added because DA set to 0 on new add when this is called
IF $DATA(AUPIDS(.03))
IF $DATA(AUPX)
SET NAM=AUPX
SET DOB=AUPIDS(.03)
+2 IF '$TEST
SET L=^DPT(DA,0)
SET DOB=$PIECE(L,"^",3)
SET NAM=$PIECE(L,"^",1)
+3 ; DG*5.3*621
+4 IF DOB=""
SET DOB=2000000
+5 SET L1=$EXTRACT($PIECE(NAM," ",2),1)
SET L3=$EXTRACT(NAM,1)
SET NAM=$PIECE(NAM,",",2)
SET L2=$EXTRACT(NAM,1)
+6 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"
+7 KILL L1,L2,L3,Z,DOB,NAM
QUIT
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
