source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREXDS.m@ 1424

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

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1RMPREXDS ;PHX/HNB -National Data Extract Pros Disability Codes - 10/30/96
2 ;;3.0;PROSTHETICS;**18**;Feb 09, 1996
3 ;can't enter from top
4 Q
5EN(RMPRDT1,RMPRDT2) ;entry point
6 ;send message to chief prosthetics notify of activation
7 D NOT
8 S RMPRB=0,CNT=1
9 K ^TMP($J),^TMP("RMPR",$J),^TMP("RMPRF",$J)
10 F S RMPRB=$O(^RMPR(660,"B",RMPRB)) Q:(RMPRB>RMPRDT2)!(RMPRB'>0) D
11 .Q:RMPRB<RMPRDT1
12 .S RMPRA=0
13 .F S RMPRA=$O(^RMPR(660,"B",RMPRB,RMPRA)) Q:RMPRA'>0 D
14 . .S DFN=$P($G(^RMPR(660,RMPRA,0)),U,2)
15 . .Q:DFN=""
16 . .Q:$D(^TMP("RMPR",$J,DFN))
17 . .;leave out historical records
18 . .Q:$P(^RMPR(660,RMPRA,0),U,15)
19 . .S STN=$P(^RMPR(660,RMPRA,0),U,10)
20 . .Q:STN=""
21 . .S STN=$P($G(^DIC(4,STN,99)),U,1)
22 . .Q:STN=""
23 . .D SSN
24 . .D DS
25 . .D CK
26 D:$D(^TMP($J)) MAIL1
27 D MAILS
28 Q
29DS ;patients disability codes/records
30 Q:$D(^TMP("RMPR",$J,DFN))
31 D GETS^DIQ(665,DFN_",","**","","RDIS")
32 MERGE R19=RDIS(665.01)
33 K RDIS
34 Q:'$D(R19)
35 S B1=0
36 F S B1=$O(R19(B1)) Q:B1="" D
37 .S B2=0
38 .F S B2=$O(R19(B1,B2)) Q:B2="" D
39 . .;format for mailman ^TMP($J,counter)=station number^ssn^field^value
40 . .Q:B2=1
41 . .Q:B2>5
42 . .S ^TMP($J,CNT)=STN_U_RMPRSSN_U_B2_U_R19(B1,B2)
43 . .S ^TMP("RMPR",$J,DFN)=""
44 . .S CNT=CNT+1
45 K R19,RMPRSSN,STN
46 Q
47SSN ;pull ssn
48 D DEM^VADPT
49 S RMPRSSN=+VADM(2)
50 K VADM
51 Q
52NOT ;send notificaton to mail group
53 S Y=RMPRDT1 D DD^%DT S RMPRDAT1=Y
54 S Y=RMPRDT2 D DD^%DT S RMPRDAT2=Y
55 S XMDUZ=.5
56 S XMY("G.RMPR SERVER")=""
57 S XMSUB="Prosthetics Data Extract "_RMPRDAT1_" to "_RMPRDAT2
58 S RMPRMSG(1)="The National Data Server has been activated today by Prosthetics HQ."
59 S RMPRMSG(2)="Data has been collected for the date range "_RMPRDAT1_" to "_RMPRDAT2_"."
60 S RMPRMSG(3)="Disability Code information will be transmitted."
61 S RMPRMSG(4)="This was activated by "_$P(XMFROM,"@",1)
62 S RMPRMSG(5)=""
63 S XMTEXT="RMPRMSG("
64 D ^XMD
65 K RMPRMSG,RMPRDAT1,RMPRDAT2
66 Q
67CK ;check line length to send
68 I CNT>4999 D MAIL1 S CNT=1 Q
69 Q
70MAIL1 ;send message
71 S XMTEXT="^TMP($J,"
72 S XMDUZ=.5
73 S XMY("G.PROSTHETICS@PSAS.MED.VA.GOV")=""
74 S XMSUB="PSAS National Extract From "_$P($$SITE^VASITE,U,2)
75 D ^XMD S RMPRXMZ(XMZ)=XMZ
76 K ^TMP($J)
77 Q
78MAIL ;send it
79 S CNT=1
80 F S RMPRA=$O(^TMP($J,RMPRA)) Q:RMPRA="" D
81 .S ^TMP("RMPRF",$J,CNT)=^TMP($J,RMPRA)
82 .K ^TMP($J,RMPRA)
83 .S CNT=CNT+1
84 .I CNT>4999 D
85 . .S XMTEXT="^TMP(""RMPRF"",$J,"
86 . .S XMDUZ=.5
87 . .S XMY("G.PROSTHETICS@PSAS.MED.VA.GOV")=""
88 . .S XMSUB="PSAS National Extract From "_$P($$SITE^VASITE,U,2)
89 . .D ^XMD K ^TMP("RMPRF",$J) S RMPRXMZ(XMZ)=XMZ,CNT=1
90 S XMTEXT="^TMP(""RMPRF"",$J,"
91 S XMDUZ=.5
92 S XMY("G.PROSTHETICS@PSAS.MED.VA.GOV")=""
93 S XMSUB="PSAS National Extract From "_$P($$SITE^VASITE,U,2)
94 D ^XMD K ^TMP("RMPRF",$J) S RMPRXMZ(XMZ)=XMZ
95MAILS ;mail summary message
96 Q:'$D(RMPRXMZ)
97 S RMPRB=0,RMPRTOT=0
98 F S RMPRB=$O(^TMP("RMPR",$J,RMPRB)) Q:RMPRB="" S RMPRTOT=RMPRTOT+1
99 S XMTEXT="RMPRXMZ("
100 S RMPRXMZ(1)="Total Number of Unique SSN's for this site: "_RMPRTOT
101 S XMDUZ=.5
102 S XMY("G.PROSTHETICS@PSAS.MED.VA.GOV")=""
103 S XMSUB="PSAS Summary National Extract From "_$P($$SITE^VASITE,U,2)
104 D ^XMD
105 ;END
Note: See TracBrowser for help on using the repository browser.