- 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
