source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRET.m@ 1651

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

initial load of WorldVistAEHR

File size: 2.6 KB
Line 
1RMPRET ;Hines-OI/HNC - ITEM SERVER ;01/14/2005
2 ;;3.0;PROSTHETICS;**103**;Feb 09, 1996
3 ;
4 ;DBIA # 10072 - for routine REMSBMSG^XMA1C
5 ;
6EN ;Entry Point
7 ;HCPCS SERVER
8 ;
9 ;K ^TMP($J)
10 X XMREC D
11 .;check
12 .S RMPRWHO3=XMRG
13 .X XMREC S RMPRWHO1=XMRG
14 .X XMREC S RMPRWHO2=XMRG
15 .S RMPRWHO=$$DEC^RMPR4LI(RMPRWHO3,RMPRWHO1,RMPRWHO2)
16 .S RMPRCHK=0
17 .F S RMPRCHK=$O(^RMPR(669.9,RMPRCHK)) Q:RMPRCHK>0
18 .I RMPRWHO'=$P(^RMPR(669.9,RMPRCHK,"INV"),U,4) D NOGO Q
19 D NOW^%DTC S RMPRWHN=%
20 S CNT=6,RMPRDLM=","_"""I"""
21 S (RMPRIEN,RMPRFLD,RMPRVL,RMPRIEN2)=""
22 F X XMREC Q:XMRG="" D
23 .;S RMPRMSG(CNT+10000)=$P(XMRG,RMPRDLM,1)_$P(XMRG,RMPRDLM,2)
24 .S RMPRIEN=$P(XMRG,U,1)
25 .S RMPRFLD=$P(XMRG,U,2)
26 .S RMPRVL=$P(XMRG,U,3)
27 .S RMPRIEN2=$P(XMRG,U,4)
28 .I RMPRFLD=.01 S RMPRMSG(CNT)="HCPCS: "_RMPRVL
29 .;S ^TMP($J,RMPRIEN,RMPRFLD)=RMPRVL
30 .;check to see if new and add
31 .I '$D(^RMPR(661.1,RMPRIEN)) D
32 . .S $P(^RMPR(661.1,RMPRIEN,0),U,1)=RMPRVL
33 . .S DIK="^RMPR(661.1,"
34 . .S DA=RMPRIEN D IX1^DIK
35 .S UPD(661.1,RMPRIEN_",",1.1)=RMPRWHN
36 .S UPD(661.1,RMPRIEN_",",1.2)=XMFROM
37 .I RMPRFLD="661.18" D
38 . .;START DESCRIPTION
39 . .S ^RMPR(661.1,RMPRIEN,2,RMPRIEN2,0)=RMPRVL
40 . .S CNTIEN=0,CNTIEN1=0
41 . .F S CNTIEN=$O(^RMPR(661.1,RMPRIEN,2,CNTIEN)) Q:CNTIEN'>0 D
42 . . .S CNTIEN1=CNTIEN1+1
43 . .S ^RMPR(661.1,RMPRIEN,2,0)="^661.18^"_CNTIEN1_U_CNTIEN1
44 . .S DIK="^RMPR(661.1,"
45 . .S DA=RMPRIEN D IX1^DIK
46 . .S RMPRFLD=""
47 .I RMPRFLD="" Q
48 .I RMPRFLD'=.01 S UPD(661.1,RMPRIEN_",",RMPRFLD)=RMPRVL
49 .S CNT=CNT+1
50 D FILE^DIE("","UPD","ERROR")
51 I $D(ERROR("DIERR")) S RMPRMSG(1.1)="******* ERROR ENCOUNTERED*******"
52 S XMDUZ=.5
53 S XMY("G.RMPR SERVER")=""
54 S XMY("VHACOPSASPIPReport@med.va.gov")=""
55 S XMSUB="PSAS HCPCS Item Server Update "_$P($$SITE^VASITE,U,2)
56 S RMPRMSG(1)="The National PSAS Item Server has been activated today by Prosthetics HQ."
57 S RMPRMSG(2)="Please print your HCPCS Mapping File."
58 S RMPRMSG(3)=""
59 S RMPRMSG(4)="This was activated by "_$P(XMFROM,"@",1)
60 S RMPRMSG(5)=""
61 S XMTEXT="RMPRMSG("
62 D ^XMD
63 G EXIT
64 Q
65NOGO ;message not valid
66 S XMDUZ=.5
67 S XMY("G.RMPR SERVER")=""
68 S XMY("VHACOPSASPIPReport@med.va.gov")=""
69 S XMSUB="**ERROR** Not Authorized HCPCS Item Server Update From "_$P($$SITE^VASITE,U,2)
70 S RMPRMSG(1)="The National PSAS Item Server was unsuccessful today."
71 S RMPRMSG(2)="****ERROR**** Not Authorized!"
72 S RMPRMSG(3)=""
73 S RMPRMSG(4)="This was activated by "_XMFROM
74 S XMTEXT="RMPRMSG("
75 D ^XMD
76 ;
77EXIT ;common exit point
78 S XMSER="S."_XQSOP,XMZ=XQMSG D REMSBMSG^XMA1C
79 K %,CNT,DA,DIK,ERROR,RMPRDL,RMPRFLD,RMPRIEN2,RMPRMSG,RMPRVL,RMPRWHN
80 K UPD,XMDUZ,XMFROM,XMREC,XMRG,XMSUB,XMTEXT,XMY,RMPRIEN,RMPRDLM,CNTIEN,CNTIEN1
81 K RMPRWHO,RMPRWHO1,RMPRWHO2,RMPRWHO3,XMSER,RMPRCHK,XMZ,XQMSG,XQSOP
82 ;END
Note: See TracBrowser for help on using the repository browser.