- DGMTDD1 ;ALB/MIR,JAN,AEG,ERC,BAJ - DD calls from income screening files ; 12/8/06 3:35pm
- ;;5.3;PIMS;**180,313,345,401,653,688,1015,1016**;JUN 30, 2012;Build 20
- ;
- ; 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
- DGMTDD1 ;ALB/MIR,JAN,AEG,ERC,BAJ - DD calls from income screening files ; 12/8/06 3:35pm
- +1 ;;5.3;PIMS;**180,313,345,401,653,688,1015,1016**;JUN 30, 2012;Build 20
- +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