source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTDD1.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1DGMTDD1 ;ALB/MIR,JAN,AEG,ERC,BAJ - DD calls from income screening files ; May 18, 2006
2 ;;5.3;Registration;**180,313,345,401,653**;Aug 13, 1993;Build 2
3 ;
4 ; This routine contains miscellaneous input transform and other DD
5 ; calls from income screening files.
6 ;
7 ;
8SSN ; called from the input transform of the SSN field in file 408.13
9 N %,L,DGN,DGPAT,PATNAME,PREVX,KANS
10 ;with DG*5.3*653 Pseudo SSNs will be allowed for spouse/dependents
11 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
12 I X="P"!(X="p") D PSEU S X=L K L G SSNQ
13 I X["P" D PSEU I X'=L K X,L W !!,$C(7),"Invalid Pseudo SSN, type ""P"" for valid one." Q
14 I X["P" G SSNQ
15 I X'?.AN F %=1:1:$L(X) I $E(X,%)?1P S X=$E(X,0,%-1)_$E(X,%+1,999),%=%-1
16 I X'?9N K X Q
17 I $D(X) S L=$E(X,1) I L=9 W !,*7,"The SSN must not begin with 9." K X Q
18 I $D(X),$E(X,1,3)="000" W !,*7,"First three digits cannot be zeros." K X Q
19 ;
20 ; warning if the spouse's/dependent's SSN is found in the PATIENT file
21 ; and spouse/dependent is not a veteran. spouse/dependent is a veteran
22 ; if name, sex, DOB match.
23 ;
24 ; input (OPTIONAL)
25 ; ANS(.01) = NAME, ANS(.02) = SEX, ANS(.03) = DOB
26 ;
27 ; if newly entered values (those not yet committed to dbase) not
28 ; supplied then pull current detail from the Person Income file
29 ; (#408.13) for this dependent.
30 I '$G(ANS(.01)),'$G(ANS(.02)),'$G(ANS(.03)) D
31 . N REC,FLD
32 . D GETS^DIQ(408.13,DA,".01;.02;.03","I","REC")
33 . F FLD=".01",".02",".03" S ANS(FLD)=REC(408.13,DA_",",FLD,"I")
34 . S KANS=1
35 E S KANS=0
36 ;
37 S DGN=$O(^DPT("SSN",X,0)) G:'DGN SSDEP S DGPAT=$G(^DPT(DGN,0))
38 I $P(DGPAT,"^",3)=ANS(.03),($P(DGPAT,"^",2)=ANS(.02)),($P(DGPAT,"^")=ANS(.01)) G SSDEP
39 S PATNAME=$P(DGPAT,"^") D WARN Q
40 ;
41SSDEP ; warning if spouse's/dependent's SSN is found in file 408.13 and
42 ; name, sex, DOB don't match
43 S DGN=$O(^DGPR(408.13,"SSN",X,0)) G:'DGN SSNQ S DGPAT=$G(^DGPR(408.13,DGN,0))
44 I $P(DGPAT,"^",3)=ANS(.03),($P(DGPAT,"^",2)=ANS(.02)),($P(DGPAT,"^")=ANS(.01)) G SSNQ
45 S PATNAME=$P($G(^DGPR(408.13,DGN,0)),"^") D WARN Q
46 ;
47SSNQ K:KANS ANS Q
48 ;
49 ;
50PSEU ;create a Pseudo SSN using same algorithm as file 2 in PSEU^DGRPDD1
51 S KANS=""
52 I $G(ANS(.01))']""!($G(ANS(.03))'?7N) D
53 . S DGNODE0=^DGPR(408.13,DA,0)
54 . S ANS(.01)=$P(DGNODE0,U),ANS(.03)=$P(DGNODE0,U,3)
55 I $D(ANS(.01)) S NAM=ANS(.01)
56 I $D(ANS(.03)) S DOB=ANS(.03)
57 I $G(DOB)="" S DOB=2000000
58 S L1=$E($P(NAM," ",2)),L3=$E(NAM),NAM=$P(NAM,",",2),L2=$E(NAM)
59 S Z=L1 D CON S L1=Z
60 S Z=L2 D CON S L2=Z
61 S Z=L3 D CON S L3=Z
62 S L=L2_L1_L3_$E(DOB,4,7)_$E(DOB,2,3)_"P"
63 Q
64CON ;
65 S Z=$A(Z)-65\3+1 S:Z<0 Z=0
66 Q
67 ;
68WARN ; printed WARNING message to alert user that spouse/dependent SSN be
69 ; that of a veteran in Patient/Income Person File.
70 W !,*7,"Warning - ",X," belongs to patient ",PATNAME
71 K DIR S PREVX=X,DIR(0)="YA",DIR("A")="Are you sure this is the correct SSN? ",DIR("B")="YES" D ^DIR
72 I Y=1 S X=PREVX K PREVX,DIR("B") Q
73 E K DIR("B"),X Q
74 ;
75REL ; called from the input transform of the RELATIONSHIP field of file 408.12...sets DIC("S")
76 N DGNODE,DGX,SEX
77 S DGNODE=$G(^DGPR(408.12,DA,0)),DGX=$P(DGNODE,"^",2) Q:'DGNODE
78 I DGX,(DGX<3) S DIC("S")="I Y="_DGX Q
79 S DGX=$P(DGNODE,"^",3),SEX=$P($G(@("^"_$P(DGX,";",2)_+DGX_",0)")),"^",2)
80 S DIC("S")="I Y>2,(""E"_SEX_"""[$P(^(0),""^"",3))"
81 I $D(DGTYPE),DGTYPE="C" S DIC("S")=DIC("S")_",(Y<7)"
82 Q
Note: See TracBrowser for help on using the repository browser.