Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRET

RMPRET.m

Go to the documentation of this file. 
  1. RMPRET ;Hines-OI/HNC - ITEM SERVER ;01/14/2005
  1.  ;;3.0;PROSTHETICS;**103,172**;Feb 09, 1996;Build 2
  1.  ;
  1.  ;DBIA # 10072 - for routine REMSBMSG^XMA1C
  1.  ;
  1.  ;Patch RMPR*3.0*172 For description change to insure prior 
  1.  ;                   description entirely removed before updating
  1.  ;                   with new description lines.
  1.  ;
  1. EN ;Entry Point
  1.  ;HCPCS SERVER
  1.  ;
  1.  ;K ^TMP($J)
  1.  X XMREC D
  1.  .;check
  1.  .S RMPRWHO3=XMRG
  1.  .X XMREC S RMPRWHO1=XMRG
  1.  .X XMREC S RMPRWHO2=XMRG
  1.  .S RMPRWHO=$$DEC^RMPR4LI(RMPRWHO3,RMPRWHO1,RMPRWHO2)
  1.  .S RMPRCHK=0
  1.  .F  S RMPRCHK=$O(^RMPR(669.9,RMPRCHK)) Q:RMPRCHK>0
  1.  .I RMPRWHO'=$P(^RMPR(669.9,RMPRCHK,"INV"),U,4) D NOGO Q
  1.  D NOW^%DTC S RMPRWHN=%
  1.  S CNT=6,RMPRDLM=","_"""I"""
  1.  S (RMPRIEN,RMPRFLD,RMPRVL,RMPRIEN2)=""
  1.  F  X XMREC Q:XMRG=""  D
  1.  .;S RMPRMSG(CNT+10000)=$P(XMRG,RMPRDLM,1)_$P(XMRG,RMPRDLM,2)
  1.  .S RMPRIEN=$P(XMRG,U,1)
  1.  .S RMPRFLD=$P(XMRG,U,2)
  1.  .S RMPRVL=$P(XMRG,U,3)
  1.  .S RMPRIEN2=$P(XMRG,U,4)
  1.  .I RMPRFLD=.01 S RMPRMSG(CNT)="HCPCS: "_RMPRVL
  1.  .;S ^TMP($J,RMPRIEN,RMPRFLD)=RMPRVL
  1.  .;check to see if new and add
  1.  .I '$D(^RMPR(661.1,RMPRIEN)) D
  1.  . .S $P(^RMPR(661.1,RMPRIEN,0),U,1)=RMPRVL
  1.  . .S DIK="^RMPR(661.1,"
  1.  . .S DA=RMPRIEN D IX1^DIK
  1.  .S UPD(661.1,RMPRIEN_",",1.1)=RMPRWHN
  1.  .S UPD(661.1,RMPRIEN_",",1.2)=XMFROM
  1.  .I RMPRFLD="661.18" D
  1.  . .;START DESCRIPTION
  1.  . .I RMPRIEN2=1 D  K DIK,DA,DA(1)      ;RMPR*3.0*172 Clear current description in file before new description lines entered
  1.  . . .F I=1:1:20 I $D(^RMPR(661.1,RMPRIEN,2,I,0)) S DA=I,DA(1)=RMPRIEN,DIK="^RMPR(661.1,"_DA(1)_",2," D ^DIK
  1.  . . .K DIK,DA,DA(1),I,^RMPR(661.1,RMPRIEN,2,"B")
  1.  . .S ^RMPR(661.1,RMPRIEN,2,RMPRIEN2,0)=RMPRVL
  1.  . .S CNTIEN=0,CNTIEN1=0
  1.  . .F  S CNTIEN=$O(^RMPR(661.1,RMPRIEN,2,CNTIEN)) Q:CNTIEN'>0  D
  1.  . . .S CNTIEN1=CNTIEN1+1
  1.  . .S ^RMPR(661.1,RMPRIEN,2,0)="^661.18^"_CNTIEN1_U_CNTIEN1
  1.  . .S DIK="^RMPR(661.1,"
  1.  . .S DA=RMPRIEN D IX1^DIK
  1.  . .S RMPRFLD=""
  1.  .I RMPRFLD="" Q
  1.  .I RMPRFLD'=.01 S UPD(661.1,RMPRIEN_",",RMPRFLD)=RMPRVL
  1.  .S CNT=CNT+1
  1.  D FILE^DIE("","UPD","ERROR")
  1.  I $D(ERROR("DIERR")) S RMPRMSG(1.1)="******* ERROR ENCOUNTERED*******"
  1.  S XMDUZ=.5
  1.  S XMY("G.RMPR SERVER")=""
  1.  S XMY("VHACOPSASPIPReport@domain.ext")=""
  1.  S XMSUB="PSAS HCPCS Item Server Update "_$P($$SITE^VASITE,U,2)
  1.  S RMPRMSG(1)="The National PSAS Item Server has been activated today by Prosthetics HQ."
  1.  S RMPRMSG(2)="Please print your HCPCS Mapping File."
  1.  S RMPRMSG(3)=""
  1.  S RMPRMSG(4)="This was activated by "_$P(XMFROM,"@",1)
  1.  S RMPRMSG(5)=""
  1.  S XMTEXT="RMPRMSG("
  1.  D ^XMD
  1.  G EXIT
  1.  Q
  1. NOGO ;message not valid
  1.  S XMDUZ=.5
  1.  S XMY("G.RMPR SERVER")=""
  1.  S XMY("VHACOPSASPIPReport@domain.ext")=""
  1.  S XMSUB="**ERROR** Not Authorized HCPCS Item Server Update From "_$P($$SITE^VASITE,U,2)
  1.  S RMPRMSG(1)="The National PSAS Item Server was unsuccessful today."
  1.  S RMPRMSG(2)="****ERROR**** Not Authorized!"
  1.  S RMPRMSG(3)=""
  1.  S RMPRMSG(4)="This was activated by "_XMFROM
  1.  S XMTEXT="RMPRMSG("
  1.  D ^XMD
  1.  ;
  1. EXIT ;common exit point
  1.  S XMSER="S."_XQSOP,XMZ=XQMSG D REMSBMSG^XMA1C
  1.  K %,CNT,DA,DIK,ERROR,RMPRDL,RMPRFLD,RMPRIEN2,RMPRMSG,RMPRVL,RMPRWHN
  1.  K UPD,XMDUZ,XMFROM,XMREC,XMRG,XMSUB,XMTEXT,XMY,RMPRIEN,RMPRDLM,CNTIEN,CNTIEN1
  1.  K RMPRWHO,RMPRWHO1,RMPRWHO2,RMPRWHO3,XMSER,RMPRCHK,XMZ,XQMSG,XQSOP
  1.  ;END