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

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

initial load of FOIAVistA 6/30/08 version
File size: 5.4 KB
Line 
1DGRP1 ;ALB/MRL,ERC - DEMOGRAPHIC DATA ; 06/22/06
2 ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653**;Aug 13, 1993;Build 2
3 ;
4EN S (DGRPS,DGRPW)=1 D H^DGRPU F I=0,.11,.121,.13,.15,.24,57,"SSN" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
5 I $P(DGRP(.15),"^",2)]"" S Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
6 ;I $P(DGRP(.15),"^",3)]"" S Z="APPLICANT IS LISTED AS 'MISSING'. NOTIFY APPROPRIATE PERSONNEL!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
7 W ! S Z=1 D WW^DGRPV W " Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV
8 W "SS: " S X=$P(DGRP(0),"^",9),Z=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),Z1=13 D WW1^DGRPV
9 W ! S Z="",Z1=8 D WW1^DGRPV S Y=$P(DGRP(0),"^",3) X ^DD("DD") W "DOB: ",Y
10 ;add Pseudo SSN Reason - DG*5.3*653, ERC
11 I $P(DGRP(0),U,9)["P" D
12 . N DGSPACE
13 . S DGSPACE=10-$L(Y) ;adjust to maintain spacing on screen
14 . S Z1=12+DGSPACE D WW1^DGRPV W "PSSN Reason: "
15 . I $P(DGRP(0),U,9)["P" D
16 . . N DGREAS D SSNREAS(.DGREAS)
17 . . Q:$G(DGREAS)']""
18 . . W DGREAS
19 D GETNCAL ;Display name component, sex, and alias information
20 S Z=3,DGRPX=DGRP(0) D WW^DGRPV W " Remarks: ",$S($P(DGRPX,"^",10)]"":$E($P(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT") S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU
21 S Z=4 D WW^DGRPV W " Permanent Address: " S Z=" ",Z1=17
22 D WW1^DGRPV S Z=5,DGRPW=0 D WW^DGRPV W " Temporary Address: "
23 W !?11
24 S Z1=40,Z=$S($D(DGA(1)):DGA(1),1:"NONE ON FILE") D WW1^DGRPV W $S($D(DGA(2)):DGA(2),1:"NO TEMPORARY ADDRESS")
25 S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>50) !?11 W:'(I#2) ?51 W DGA(I)
26 S DGCC=$S($D(^DIC(5,+$P(DGRP(.11),U,5),1,+$P(DGRP(.11),U,7),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W !?3,"County: ",DGCC K DGCC
27 S DGCC=$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$D(^DIC(5,+$P(DGRP(.121),U,5),1,+$P(DGRP(.121),U,11),0)):$E($P(^(0),U,1),1,20)_$S($P(^(0),U,3)]"":" ("_$P(^(0),U,3)_")",1:""),1:DGRPU) W ?43,"County: ",DGCC K DGCC
28 W !?4,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU),?44,"Phone: ",$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU)
29 S X="NOT APPLICABLE" I $P(DGRP(.121),U,9)="Y" S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU)
30 W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU),?42,"From/To: ",X
31 W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
32 ;
33 ; *** Additional displays added for Pre-Registration
34 I $G(DGPRFLG)=1 D
35 . W !
36 . N I,MIS1,X,X1,SA1,TP1,X2,X3,ES1
37 . I $D(^DIA(2,"B",DFN)) S X="" F I=1:1 S X=$O(^DIA(2,"B",DFN,X)) Q:X<1 I $P(^DIA(2,X,0),U,3)=.05 S MIS1=$P(^DIA(2,X,0),U,2)
38 . W:$D(MIS1)>0 !," [MARITAL STATUS CHANGED:] "_$$FMTE^XLFDT(MIS1,"5D")
39 . I $D(^DIA(2,"B",DFN)) S X1="" F I=1:1 S X1=$O(^DIA(2,"B",DFN,X1)) Q:X1<1 S:$P(^DIA(2,X1,0),U,3)=.111 SA1=$P(^DIA(2,X1,0),U,2)
40 . W:$D(SA1)>0 !," [STREET ADDRESS LAST CHANGED:] "_$$FMTE^XLFDT(SA1,"5D")
41 . I $D(^DIA(2,"B",DFN)) S X2="" F I=1:1 S X2=$O(^DIA(2,"B",DFN,X2)) Q:X2<1 S:$P(^DIA(2,X2,0),U,3)=.131 TP1=$P(^DIA(2,X2,0),U,2)
42 . W:$D(TP1)>0 !," [HOME PHONE NUMBER CHANGED:] "_$$FMTE^XLFDT(TP1,"5D")
43 . I $D(^DIA(2,"B",DFN)) S X3="" F I=1:1 S X3=$O(^DIA(2,"B",DFN,X3)) Q:X3<1 S:$P(^DIA(2,X3,0),U,3)=.31115 ES1=$P(^DIA(2,X3,0),U,2)
44 . W:$D(ES1)>0 !," [EMPLOYMENT STATUS CHANGED:] "_$$FMTE^XLFDT(ES1,"5D")
45 . ; The IB Insurance API does not provide date entered or edited information, so this information will not be displayed for preregistration
46 . I $$INSUR^IBBAPI(DFN,"","AR",.DGDATA,"1,10,11") F DGI=0:0 S DGI=$O(DGDATA("IBBAPI","INSUR",DGI)) Q:'DGI D
47 .. W !," [INSURANCE:] ",$P(DGDATA("IBBAPI","INSUR",DGI,1),U,2)
48 .. W " EFFECTIVE DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,10),"5D")," EXPIRATION DATE: ",$$FMTE^XLFDT(DGDATA("IBBAPI","INSUR",DGI,11),"5D")
49 ;
50 G ^DGRPP
51 ;
52GETNCAL ;Get name component values
53 N DGCOMP,DGNC,DGI,DGA,DGALIAS,DGX,DGRPW
54 S DGNC="Family^Given^Middle^Prefix^Suffix^Degree"
55 S DGCOMP=+$G(^DPT(DFN,"NAME"))_","
56 I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP")
57 ;Get alias values
58 S DGA=0 F DGI=1:1:5 D Q:'$D(DGALIAS(DGI))
59A2 .S DGA=$O(^DPT(DFN,.01,DGA))
60 .I 'DGA D:DGI=1 Q
61 ..S DGALIAS(DGI)="< No alias entries on file >" Q
62 .I DGI=5 S DGALIAS(DGI)="< More alias entries on file >" Q
63 .S DGX=$G(^DPT(DFN,.01,DGA,0)) G:'$L(DGX) A2
64 .S DGALIAS(DGI)=$P(DGX,U),DGX=$P(DGX,U,2)
65 .I $L(DGX) D
66 ..S DGX=" "_$E(DGX,1,3)_"-"_$E(DGX,4,5)_"-"_$E(DGX,6,9)
67 ..; BAJ DG*5.3*700 retrofit 06/22/06
68 ..S DGALIAS(DGI)=$E(DGALIAS(DGI),1,19)
69 ..S $E(DGALIAS(DGI),20)=DGX Q
70 .S DGALIAS(DGI)=$E(DGALIAS(DGI),1,32)
71 .Q
72 ;Display name component, sex, multiple birth indicator and alias data
73 F DGI=1:1:6 D
74 .W !?5,$J($P(DGNC,U,DGI),6),": ",$E($G(DGCOMP(20,DGCOMP,DGI)),1,$S(DGI=1:23,1:27))
75 .I DGI=1 S (Z,DGRPW)=1 W ?43,"Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=3 D WW1^DGRPV
76 .; BAJ DG*5.3*700 retrofit 06/2206
77 .I DGI=1 S (Z,DGRPW)=1 W ?56,"MBI: " S X=$P($G(^DPT(DFN,"MPIMB")),U),Z=$S(X="N":"NO",X="Y":"*MULTIPLE BIRTH*",1:DGRPU),Z1=16 D WW1^DGRPV
78 .I DGI=2 S DGRPW=0,Z=2 W ?37 D WW^DGRPV W " Alias: "
79 .I DGI>1 W ?47,$G(DGALIAS(DGI-1))
80 .Q
81 Q
82SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC
83 S DGREAS=$P(DGRP("SSN"),U)
84 I $G(DGREAS)']"" Q
85 S DGREAS=$S(DGREAS="R":"Refused to Provide",DGREAS="S":"SSN Unknown/Follow-up Required",DGREAS="N":"No SSN Assigned",1:"< None Entered >")
86 Q
Note: See TracBrowser for help on using the repository browser.