source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDPPAT1.m@ 1780

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

initial load of WorldVistAEHR
File size: 4.6 KB
Line 
1SDPPAT1 ;ALB/CAW-Patient Profile (Generic Patient Info) Screen 1;5/4/92
2 ;;5.3;Scheduling;**6,140**;Aug 13, 1993
3 ;
4 ;
5PDATA ; Patient Data
6 N SD,SDELIG,SDDIS,SDCNT,CNT,SDCT,SDCOPS
7 F SD=0,.3,.11,.121,.13,.32,.321,.35,.36,.52,"TYPE","VET" S SD(SD)=$G(^DPT(DFN,SD))
8 I $D(^DPT(DFN,.372,0)) S SDDIS=0 F S SDDIS=$O(^DPT(DFN,.372,SDDIS)) Q:'SDDIS D
9 .S SDDIS(SDDIS)=$G(^DPT(DFN,.372,SDDIS,0))
10 .S SDDIS(SDDIS)=$P($G(^DIC(31,+$P(SDDIS(SDDIS),U),0)),U)_" ("_$S($P(SDDIS(SDDIS),U,3):"SC-",1:"NSC-")_$P(SDDIS(SDDIS),U,2)_"%)"
11 .S SDCNT(SDDIS)=$L($P(SDDIS(SDDIS),U))+2
12 S SDELIG=0 F S SDELIG=$O(^DPT(DFN,"E",SDELIG)) Q:'SDELIG S:SDELIG'=+SD(.36) SDELIG(SDELIG)=$G(^DPT(DFN,"E",SDELIG,0))
13 S SD("MT")=$$LST^DGMTU(DFN) I 'SD("MT") S SDCOPS=$$LST^DGMTU(DFN,"",2)
14 S SDFSTCOL=22,SDSECCOL=60
15PTDOB ; Date of Birth and Marital Status Info
16 ;
17 S X="",X=$$SETSTR^VALM1("Date of Birth:",X,7,14)
18 S X=$$SETSTR^VALM1($$FTIME^VALM1($P(SD(0),U,3)),X,SDFSTCOL,18)
19 S X=$$SETSTR^VALM1("Marital Status:",X,44,15)
20 S X=$$SETSTR^VALM1($P($G(^DIC(11,+$P(SD(0),U,5),0)),U),X,SDSECCOL,20)
21 D SET(X)
22PTSEX ; Sex and Religions Pref. Info
23 ;
24 S X="",X=$$SETSTR^VALM1("Sex:",X,17,4)
25 S X=$$SETSTR^VALM1($S($P(SD(0),U,2)="F":"FEMALE",$P(SD(0),U,2)="M":"MALE",1:"UNKNOWN"),X,SDFSTCOL,18)
26 S X=$$SETSTR^VALM1("Religious Pref.:",X,43,16)
27 S X=$$SETSTR^VALM1($P($G(^DIC(13,+$P(SD(0),U,8),0)),U),X,SDSECCOL,20)
28 D SET(X)
29PTRACE ; SSN and Occupation Info
30 ;
31 S X="",X=$$SETSTR^VALM1("Patient ID:",X,10,11)
32 S X=$$SETSTR^VALM1(VA("PID"),X,SDFSTCOL,20)
33 S X=$$SETSTR^VALM1("Occupation:",X,48,11)
34 S X=$$SETSTR^VALM1($P(SD(0),U,7),X,SDSECCOL,20)
35 D SET(X)
36PWHO ; Who entered and Place of Birth
37 ;
38 S X="",X=$$SETSTR^VALM1("Who entered:",X,9,12)
39 S X=$$SETSTR^VALM1($P($G(^VA(200,+$P(SD(0),U,15),0)),U),X,SDFSTCOL,20)
40 S X=$$SETSTR^VALM1("Place of Birth:",X,44,15)
41 S X=$$SETSTR^VALM1(($P(SD(0),U,11)_$S($P(SD(0),U,12):", ",1:"")_$P($G(^DIC(5,+$P(SD(0),U,12),0)),U)),X,SDSECCOL,20)
42 D SET(X)
43PWHEN ; Date entered
44 S X="",X=$$SETSTR^VALM1("Date entered:",X,8,13)
45 S X=$$SETSTR^VALM1($S($P(SD(0),U,16):$TR($$FMTE^XLFDT($P(SD(0),U,16),"5DF")," ","0"),1:""),X,SDFSTCOL,20)
46 D SET(X)
47MT ; Current Means Test - if applicable
48 ;
49 S X="" I SD("MT")'="" D
50 .S X=$$SETSTR^VALM1("Current Means Test:",X,2,19)
51 .S X=$$SETSTR^VALM1($P(SD("MT"),U,3),X,SDFSTCOL,30)
52 .S X=$$SETSTR^VALM1("Date Means Test:",X,43,16)
53 .S X=$$SETSTR^VALM1($TR($$FMTE^XLFDT($P(SD("MT"),U,2),"5DF")," ","0"),X,SDSECCOL,20)
54 I $D(SDCOPS),+SDCOPS D
55 .S X=$$SETSTR^VALM1("Current Co-Pay Test:",X,1,20)
56 .S X=$$SETSTR^VALM1($P(SDCOPS,U,3),X,SDFSTCOL,30)
57 .S X=$$SETSTR^VALM1("Date Co-Pay Test:",X,42,17)
58 .S X=$$SETSTR^VALM1($TR($$FMTE^XLFDT($P(SDCOPS,U,2),"5DF")," ","0"),X,SDSECCOL,20)
59 D SET(X)
60REMARK ; Remark
61 S X="" I $P(SD(0),U,10)'="" D
62 .S X=$$SETSTR^VALM1("Remarks:",X,13,8)
63 .S X=$$SETSTR^VALM1($P(SD(0),U,10),X,SDFSTCOL,60)
64 D SET(X)
65PRIME ; Primary Eligibility
66 ;
67 S X="",X=$$SETSTR^VALM1("Primary Eligibility:",X,1,20)
68 S X=$$SETSTR^VALM1($$FELIG(SD(.36)),X,SDFSTCOL,30)
69 D SET(X)
70OTHERE ; Other Eligibilities and Date of Death
71 ;
72 S X="",X=$$SETSTR^VALM1("Other Eligibilities:",X,1,20)
73 I $P(SD(.35),U)'="" S X=$$SETSTR^VALM1("Date of Death:",X,45,14),X=$$SETSTR^VALM1($TR($$FMTE^XLFDT($P(SD(.35),U),"5DF")," ","0"),X,SDSECCOL,20)
74 D SET(X)
75VET ; List of other eligibilities and VETERAN(Y/N)
76 S SDELIG=0 F S SDELIG=$O(SDELIG(SDELIG)) Q:'SDELIG S SDCT=$G(SDCT)+1,ROU=$S(SDCT=1:"OTH1",SDCT=2:"OTH2",1:"OTHM") D @ROU I SDCT=5 S X="",X=$$SETSTR^VALM1("(this patient has more 'other eligibilities that are not listed)",X,10,65) D SET(X) Q
77 I '$D(SDCT) D
78 .S X="",X=$$SETSTR^VALM1("VETERAN(Y/N):",X,46,13)
79 .S X=$$SETSTR^VALM1($S(SD("VET")="N":"NO",SD("VET")="Y":"YES",1:"UNKNOWN"),X,SDSECCOL,7)
80 .D SET(X)
81 .S X="",X=$$SETSTR^VALM1("Type:",X,54,5)
82 .S X=$$SETSTR^VALM1($P($G(^DG(391,+SD("TYPE"),0)),U),X,SDSECCOL,20)
83 .D SET(X)
84 F SD=SDLN:1:12 D SET("")
85 D ^SDPPAT2
86 S VALMCNT=SDLN
87 Q
88SET(X) ; Set in ^TMP global for display
89 ;
90 S SDLN=$G(SDLN)+1,^TMP("SDPP",$J,SDLN,0)=X
91 Q
92OTH1 ; First 'Other' Eligibility' and VETERAN(Y/N)
93 S X="",X=$$SETSTR^VALM1($$FELIG(SDELIG(SDELIG)),X,10,30)
94 S X=$$SETSTR^VALM1("VETERAN(Y/N):",X,46,13)
95 S X=$$SETSTR^VALM1($S(SD("VET")="N":"NO",SD("VET")="Y":"YES",1:"UNKNOWN"),X,SDSECCOL,7)
96 D SET(X)
97 Q
98OTH2 ; Second 'Other Eligbility' and TYPE
99 S X="",X=$$SETSTR^VALM1($$FELIG(SDELIG(SDELIG)),X,10,30)
100 S X=$$SETSTR^VALM1("Type:",X,53,5)
101 S X=$$SETSTR^VALM1($P($G(^DG(391,+SD("TYPE"),0)),U),X,SDSECCOL,20)
102 D SET(X)
103 Q
104OTHM ; Rest of 'Other Eligibilities'
105 Q:SDCT>4
106 S X="",X=$$SETSTR^VALM1($$FELIG(SDELIG(SDELIG)),X,10,30)
107 D SET(X)
108 Q
109FELIG(ELIG) ;
110 ; input - pointer to eligibility file
111 ; output - name of eligibility
112 Q $P($G(^DIC(8,+ELIG,0)),U)
Note: See TracBrowser for help on using the repository browser.