DGMTDD1 ;ALB/MIR,JAN,AEG,ERC,BAJ - DD calls from income screening files ; 12/8/06 3:35pm
;;5.3;Registration;**180,313,345,401,653,688**;Aug 13, 1993;Build 29
;
; This routine contains miscellaneous input transform and other DD
; calls from income screening files.
;
;
SSN ; called from the input transform of the SSN field in file 408.13
N %,L,DGN,DGPAT,PATNAME,PREVX,KANS
;with DG*5.3*653 Pseudo SSNs will be allowed for spouse/dependents
I X'?9N&(X'?3N1"-"2N1"-"4N)&(X'?9N1"P")&(X'?3N1"-"2N1"-"4N1"P"),(X'?1"P")&(X'?1"p") W !,"Response must be either nine numbers, be in the format nnn-nn-nnnn",!,"or include a ""P"" for a Pseudo SSN." K X Q
I X="P"!(X="p") D PSEU S X=L K L G SSNQ
I X["P" D PSEU I X'=L K X,L W !!,$C(7),"Invalid Pseudo SSN, type ""P"" for valid one." Q
I X["P" G SSNQ
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'?9N K X Q
I $D(X) S L=$E(X,1) I L=9 W !,*7,"The SSN must not begin with 9." K X Q
I $D(X),$E(X,1,3)="000" W !,*7,"First three digits cannot be zeros." K X Q
;
; warning if the spouse's/dependent's SSN is found in the PATIENT file
; and spouse/dependent is not a veteran. spouse/dependent is a veteran
; if name, sex, DOB match.
;
; input (OPTIONAL)
; ANS(.01) = NAME, ANS(.02) = SEX, ANS(.03) = DOB
;
; if newly entered values (those not yet committed to dbase) not
; supplied then pull current detail from the Person Income file
; (#408.13) for this dependent.
I '$G(ANS(.01)),'$G(ANS(.02)),'$G(ANS(.03)) D
. N REC,FLD
. D GETS^DIQ(408.13,DA,".01;.02;.03","I","REC")
. F FLD=".01",".02",".03" S ANS(FLD)=REC(408.13,DA_",",FLD,"I")
. S KANS=1
E S KANS=0
;
S DGN=$O(^DPT("SSN",X,0)) G:'DGN SSDEP S DGPAT=$G(^DPT(DGN,0))
I $P(DGPAT,"^",3)=ANS(.03),($P(DGPAT,"^",2)=ANS(.02)),($P(DGPAT,"^")=ANS(.01)) G SSDEP
S PATNAME=$P(DGPAT,"^") D WARN Q
;
SSDEP ; warning if spouse's/dependent's SSN is found in file 408.13 and
; name, sex, DOB don't match
S DGN=$O(^DGPR(408.13,"SSN",X,0)) G:'DGN SSNQ S DGPAT=$G(^DGPR(408.13,DGN,0))
I $P(DGPAT,"^",3)=ANS(.03),($P(DGPAT,"^",2)=ANS(.02)),($P(DGPAT,"^")=ANS(.01)) G SSNQ
S PATNAME=$P($G(^DGPR(408.13,DGN,0)),"^") D WARN Q
;
SSNQ K:KANS ANS Q
;
;
PSEU ;create a Pseudo SSN using same algorithm as file 2 in PSEU^DGRPDD1
S KANS=""
I $G(ANS(.01))']""!($G(ANS(.03))'?7N) D
. S DGNODE0=^DGPR(408.13,DA,0)
. S ANS(.01)=$P(DGNODE0,U),ANS(.03)=$P(DGNODE0,U,3)
I $D(ANS(.01)) S NAM=ANS(.01)
I $D(ANS(.03)) S DOB=ANS(.03)
I $G(DOB)="" S DOB=2000000
S L1=$E($P(NAM," ",2)),L3=$E(NAM),NAM=$P(NAM,",",2),L2=$E(NAM)
S Z=L1 D CON S L1=Z
S Z=L2 D CON S L2=Z
S Z=L3 D CON S L3=Z
S L=L2_L1_L3_$E(DOB,4,7)_$E(DOB,2,3)_"P"
Q
CON ;
S Z=$A(Z)-65\3+1 S:Z<0 Z=0
Q
;
WARN ; printed WARNING message to alert user that spouse/dependent SSN be
; that of a veteran in Patient/Income Person File.
W !,*7,"Warning - ",X," belongs to patient ",PATNAME
K DIR S PREVX=X,DIR(0)="YA",DIR("A")="Are you sure this is the correct SSN? ",DIR("B")="YES" D ^DIR
I Y=1 S X=PREVX K PREVX,DIR("B") Q
E K DIR("B"),X Q
;
REL ; called from the input transform of the RELATIONSHIP field of file 408.12...sets DIC("S")
N DGNODE,DGX,SEX
S DGNODE=$G(^DGPR(408.12,DA,0)),DGX=$P(DGNODE,"^",2) Q:'DGNODE
I DGX,(DGX<3) S DIC("S")="I Y="_DGX Q
S DGX=$P(DGNODE,"^",3),SEX=$P($G(@("^"_$P(DGX,";",2)_+DGX_",0)")),"^",2)
S DIC("S")="I Y>2,(""E"_SEX_"""[$P(^(0),""^"",3))"
I $P(DGNODE,U,2)>6 I $$CNTDEPS^DGMTU11(+DGNODE)>18 S DIC("S")=DIC("S")_",(Y>6)"
I $D(DGTYPE),DGTYPE="C" S DIC("S")=DIC("S")_",(Y<7)"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMTDD1 3612 printed Apr 09, 2024@21:45:38 Page 2
DGMTDD1 ;ALB/MIR,JAN,AEG,ERC,BAJ - DD calls from income screening files ; 12/8/06 3:35pm
+1 ;;5.3;Registration;**180,313,345,401,653,688**;Aug 13, 1993;Build 29
+2 ;
+3 ; This routine contains miscellaneous input transform and other DD
+4 ; calls from income screening files.
+5 ;
+6 ;
SSN ; called from the input transform of the SSN field in file 408.13
+1 NEW %,L,DGN,DGPAT,PATNAME,PREVX,KANS
+2 ;with DG*5.3*653 Pseudo SSNs will be allowed for spouse/dependents
+3 IF X'?9N&(X'?3N1"-"2N1"-"4N)&(X'?9N1"P")&(X'?3N1"-"2N1"-"4N1"P")
IF (X'?1"P")&(X'?1"p")
WRITE !,"Response must be either nine numbers, be in the format nnn-nn-nnnn",!,"or include a ""P"" for a Pseudo SSN."
KILL X
QUIT
+4 IF X="P"!(X="p")
DO PSEU
SET X=L
KILL L
GOTO SSNQ
+5 IF X["P"
DO PSEU
IF X'=L
KILL X,L
WRITE !!,$CHAR(7),"Invalid Pseudo SSN, type ""P"" for valid one."
QUIT
+6 IF X["P"
GOTO SSNQ
+7 IF X'?.AN
FOR %=1:1:$LENGTH(X)
IF $EXTRACT(X,%)?1P
SET X=$EXTRACT(X,0,%-1)_$EXTRACT(X,%+1,999)
SET %=%-1
+8 IF X'?9N
KILL X
QUIT
+9 IF $DATA(X)
SET L=$EXTRACT(X,1)
IF L=9
WRITE !,*7,"The SSN must not begin with 9."
KILL X
QUIT
+10 IF $DATA(X)
IF $EXTRACT(X,1,3)="000"
WRITE !,*7,"First three digits cannot be zeros."
KILL X
QUIT
+11 ;
+12 ; warning if the spouse's/dependent's SSN is found in the PATIENT file
+13 ; and spouse/dependent is not a veteran. spouse/dependent is a veteran
+14 ; if name, sex, DOB match.
+15 ;
+16 ; input (OPTIONAL)
+17 ; ANS(.01) = NAME, ANS(.02) = SEX, ANS(.03) = DOB
+18 ;
+19 ; if newly entered values (those not yet committed to dbase) not
+20 ; supplied then pull current detail from the Person Income file
+21 ; (#408.13) for this dependent.
+22 IF '$GET(ANS(.01))
IF '$GET(ANS(.02))
IF '$GET(ANS(.03))
Begin DoDot:1
+23 NEW REC,FLD
+24 DO GETS^DIQ(408.13,DA,".01;.02;.03","I","REC")
+25 FOR FLD=".01",".02",".03"
SET ANS(FLD)=REC(408.13,DA_",",FLD,"I")
+26 SET KANS=1
End DoDot:1
+27 IF '$TEST
SET KANS=0
+28 ;
+29 SET DGN=$ORDER(^DPT("SSN",X,0))
if 'DGN
GOTO SSDEP
SET DGPAT=$GET(^DPT(DGN,0))
+30 IF $PIECE(DGPAT,"^",3)=ANS(.03)
IF ($PIECE(DGPAT,"^",2)=ANS(.02))
IF ($PIECE(DGPAT,"^")=ANS(.01))
GOTO SSDEP
+31 SET PATNAME=$PIECE(DGPAT,"^")
DO WARN
QUIT
+32 ;
SSDEP ; warning if spouse's/dependent's SSN is found in file 408.13 and
+1 ; name, sex, DOB don't match
+2 SET DGN=$ORDER(^DGPR(408.13,"SSN",X,0))
if 'DGN
GOTO SSNQ
SET DGPAT=$GET(^DGPR(408.13,DGN,0))
+3 IF $PIECE(DGPAT,"^",3)=ANS(.03)
IF ($PIECE(DGPAT,"^",2)=ANS(.02))
IF ($PIECE(DGPAT,"^")=ANS(.01))
GOTO SSNQ
+4 SET PATNAME=$PIECE($GET(^DGPR(408.13,DGN,0)),"^")
DO WARN
QUIT
+5 ;
SSNQ if KANS
KILL ANS
QUIT
+1 ;
+2 ;
PSEU ;create a Pseudo SSN using same algorithm as file 2 in PSEU^DGRPDD1
+1 SET KANS=""
+2 IF $GET(ANS(.01))']""!($GET(ANS(.03))'?7N)
Begin DoDot:1
+3 SET DGNODE0=^DGPR(408.13,DA,0)
+4 SET ANS(.01)=$PIECE(DGNODE0,U)
SET ANS(.03)=$PIECE(DGNODE0,U,3)
End DoDot:1
+5 IF $DATA(ANS(.01))
SET NAM=ANS(.01)
+6 IF $DATA(ANS(.03))
SET DOB=ANS(.03)
+7 IF $GET(DOB)=""
SET DOB=2000000
+8 SET L1=$EXTRACT($PIECE(NAM," ",2))
SET L3=$EXTRACT(NAM)
SET NAM=$PIECE(NAM,",",2)
SET L2=$EXTRACT(NAM)
+9 SET Z=L1
DO CON
SET L1=Z
+10 SET Z=L2
DO CON
SET L2=Z
+11 SET Z=L3
DO CON
SET L3=Z
+12 SET L=L2_L1_L3_$EXTRACT(DOB,4,7)_$EXTRACT(DOB,2,3)_"P"
+13 QUIT
CON ;
+1 SET Z=$ASCII(Z)-65\3+1
if Z<0
SET Z=0
+2 QUIT
+3 ;
WARN ; printed WARNING message to alert user that spouse/dependent SSN be
+1 ; that of a veteran in Patient/Income Person File.
+2 WRITE !,*7,"Warning - ",X," belongs to patient ",PATNAME
+3 KILL DIR
SET PREVX=X
SET DIR(0)="YA"
SET DIR("A")="Are you sure this is the correct SSN? "
SET DIR("B")="YES"
DO ^DIR
+4 IF Y=1
SET X=PREVX
KILL PREVX,DIR("B")
QUIT
+5 IF '$TEST
KILL DIR("B"),X
QUIT
+6 ;
REL ; called from the input transform of the RELATIONSHIP field of file 408.12...sets DIC("S")
+1 NEW DGNODE,DGX,SEX
+2 SET DGNODE=$GET(^DGPR(408.12,DA,0))
SET DGX=$PIECE(DGNODE,"^",2)
if 'DGNODE
QUIT
+3 IF DGX
IF (DGX<3)
SET DIC("S")="I Y="_DGX
QUIT
+4 SET DGX=$PIECE(DGNODE,"^",3)
SET SEX=$PIECE($GET(@("^"_$PIECE(DGX,";",2)_+DGX_",0)")),"^",2)
+5 SET DIC("S")="I Y>2,(""E"_SEX_"""[$P(^(0),""^"",3))"
+6 IF $PIECE(DGNODE,U,2)>6
IF $$CNTDEPS^DGMTU11(+DGNODE)>18
SET DIC("S")=DIC("S")_",(Y>6)"
+7 IF $DATA(DGTYPE)
IF DGTYPE="C"
SET DIC("S")=DIC("S")_",(Y<7)"
+8 QUIT
