RMPRET ;Hines-OI/HNC - ITEM SERVER ;01/14/2005
;;3.0;PROSTHETICS;**103,172**;Feb 09, 1996;Build 2
;
;DBIA # 10072 - for routine REMSBMSG^XMA1C
;
;Patch RMPR*3.0*172 For description change to insure prior
; description entirely removed before updating
; with new description lines.
;
EN ;Entry Point
;HCPCS SERVER
;
;K ^TMP($J)
X XMREC D
.;check
.S RMPRWHO3=XMRG
.X XMREC S RMPRWHO1=XMRG
.X XMREC S RMPRWHO2=XMRG
.S RMPRWHO=$$DEC^RMPR4LI(RMPRWHO3,RMPRWHO1,RMPRWHO2)
.S RMPRCHK=0
.F S RMPRCHK=$O(^RMPR(669.9,RMPRCHK)) Q:RMPRCHK>0
.I RMPRWHO'=$P(^RMPR(669.9,RMPRCHK,"INV"),U,4) D NOGO Q
D NOW^%DTC S RMPRWHN=%
S CNT=6,RMPRDLM=","_"""I"""
S (RMPRIEN,RMPRFLD,RMPRVL,RMPRIEN2)=""
F X XMREC Q:XMRG="" D
.;S RMPRMSG(CNT+10000)=$P(XMRG,RMPRDLM,1)_$P(XMRG,RMPRDLM,2)
.S RMPRIEN=$P(XMRG,U,1)
.S RMPRFLD=$P(XMRG,U,2)
.S RMPRVL=$P(XMRG,U,3)
.S RMPRIEN2=$P(XMRG,U,4)
.I RMPRFLD=.01 S RMPRMSG(CNT)="HCPCS: "_RMPRVL
.;S ^TMP($J,RMPRIEN,RMPRFLD)=RMPRVL
.;check to see if new and add
.I '$D(^RMPR(661.1,RMPRIEN)) D
. .S $P(^RMPR(661.1,RMPRIEN,0),U,1)=RMPRVL
. .S DIK="^RMPR(661.1,"
. .S DA=RMPRIEN D IX1^DIK
.S UPD(661.1,RMPRIEN_",",1.1)=RMPRWHN
.S UPD(661.1,RMPRIEN_",",1.2)=XMFROM
.I RMPRFLD="661.18" D
. .;START DESCRIPTION
. .I RMPRIEN2=1 D K DIK,DA,DA(1) ;RMPR*3.0*172 Clear current description in file before new description lines entered
. . .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
. . .K DIK,DA,DA(1),I,^RMPR(661.1,RMPRIEN,2,"B")
. .S ^RMPR(661.1,RMPRIEN,2,RMPRIEN2,0)=RMPRVL
. .S CNTIEN=0,CNTIEN1=0
. .F S CNTIEN=$O(^RMPR(661.1,RMPRIEN,2,CNTIEN)) Q:CNTIEN'>0 D
. . .S CNTIEN1=CNTIEN1+1
. .S ^RMPR(661.1,RMPRIEN,2,0)="^661.18^"_CNTIEN1_U_CNTIEN1
. .S DIK="^RMPR(661.1,"
. .S DA=RMPRIEN D IX1^DIK
. .S RMPRFLD=""
.I RMPRFLD="" Q
.I RMPRFLD'=.01 S UPD(661.1,RMPRIEN_",",RMPRFLD)=RMPRVL
.S CNT=CNT+1
D FILE^DIE("","UPD","ERROR")
I $D(ERROR("DIERR")) S RMPRMSG(1.1)="******* ERROR ENCOUNTERED*******"
S XMDUZ=.5
S XMY("G.RMPR SERVER")=""
S XMY("VHACOPSASPIPReport@domain.ext")=""
S XMSUB="PSAS HCPCS Item Server Update "_$P($$SITE^VASITE,U,2)
S RMPRMSG(1)="The National PSAS Item Server has been activated today by Prosthetics HQ."
S RMPRMSG(2)="Please print your HCPCS Mapping File."
S RMPRMSG(3)=""
S RMPRMSG(4)="This was activated by "_$P(XMFROM,"@",1)
S RMPRMSG(5)=""
S XMTEXT="RMPRMSG("
D ^XMD
G EXIT
Q
NOGO ;message not valid
S XMDUZ=.5
S XMY("G.RMPR SERVER")=""
S XMY("VHACOPSASPIPReport@domain.ext")=""
S XMSUB="**ERROR** Not Authorized HCPCS Item Server Update From "_$P($$SITE^VASITE,U,2)
S RMPRMSG(1)="The National PSAS Item Server was unsuccessful today."
S RMPRMSG(2)="****ERROR**** Not Authorized!"
S RMPRMSG(3)=""
S RMPRMSG(4)="This was activated by "_XMFROM
S XMTEXT="RMPRMSG("
D ^XMD
;
EXIT ;common exit point
S XMSER="S."_XQSOP,XMZ=XQMSG D REMSBMSG^XMA1C
K %,CNT,DA,DIK,ERROR,RMPRDL,RMPRFLD,RMPRIEN2,RMPRMSG,RMPRVL,RMPRWHN
K UPD,XMDUZ,XMFROM,XMREC,XMRG,XMSUB,XMTEXT,XMY,RMPRIEN,RMPRDLM,CNTIEN,CNTIEN1
K RMPRWHO,RMPRWHO1,RMPRWHO2,RMPRWHO3,XMSER,RMPRCHK,XMZ,XQMSG,XQSOP
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRET 3263 printed Dec 13, 2024@02:34:35 Page 2
RMPRET ;Hines-OI/HNC - ITEM SERVER ;01/14/2005
+1 ;;3.0;PROSTHETICS;**103,172**;Feb 09, 1996;Build 2
+2 ;
+3 ;DBIA # 10072 - for routine REMSBMSG^XMA1C
+4 ;
+5 ;Patch RMPR*3.0*172 For description change to insure prior
+6 ; description entirely removed before updating
+7 ; with new description lines.
+8 ;
EN ;Entry Point
+1 ;HCPCS SERVER
+2 ;
+3 ;K ^TMP($J)
+4 XECUTE XMREC
Begin DoDot:1
+5 ;check
+6 SET RMPRWHO3=XMRG
+7 XECUTE XMREC
SET RMPRWHO1=XMRG
+8 XECUTE XMREC
SET RMPRWHO2=XMRG
+9 SET RMPRWHO=$$DEC^RMPR4LI(RMPRWHO3,RMPRWHO1,RMPRWHO2)
+10 SET RMPRCHK=0
+11 FOR
SET RMPRCHK=$ORDER(^RMPR(669.9,RMPRCHK))
if RMPRCHK>0
QUIT
+12 IF RMPRWHO'=$PIECE(^RMPR(669.9,RMPRCHK,"INV"),U,4)
DO NOGO
QUIT
End DoDot:1
+13 DO NOW^%DTC
SET RMPRWHN=%
+14 SET CNT=6
SET RMPRDLM=","_"""I"""
+15 SET (RMPRIEN,RMPRFLD,RMPRVL,RMPRIEN2)=""
+16 FOR
XECUTE XMREC
if XMRG=""
QUIT
Begin DoDot:1
+17 ;S RMPRMSG(CNT+10000)=$P(XMRG,RMPRDLM,1)_$P(XMRG,RMPRDLM,2)
+18 SET RMPRIEN=$PIECE(XMRG,U,1)
+19 SET RMPRFLD=$PIECE(XMRG,U,2)
+20 SET RMPRVL=$PIECE(XMRG,U,3)
+21 SET RMPRIEN2=$PIECE(XMRG,U,4)
+22 IF RMPRFLD=.01
SET RMPRMSG(CNT)="HCPCS: "_RMPRVL
+23 ;S ^TMP($J,RMPRIEN,RMPRFLD)=RMPRVL
+24 ;check to see if new and add
+25 IF '$DATA(^RMPR(661.1,RMPRIEN))
Begin DoDot:2
+26 SET $PIECE(^RMPR(661.1,RMPRIEN,0),U,1)=RMPRVL
+27 SET DIK="^RMPR(661.1,"
+28 SET DA=RMPRIEN
DO IX1^DIK
End DoDot:2
+29 SET UPD(661.1,RMPRIEN_",",1.1)=RMPRWHN
+30 SET UPD(661.1,RMPRIEN_",",1.2)=XMFROM
+31 IF RMPRFLD="661.18"
Begin DoDot:2
+32 ;START DESCRIPTION
+33 ;RMPR*3.0*172 Clear current description in file before new description lines entered
IF RMPRIEN2=1
Begin DoDot:3
+34 FOR I=1:1:20
IF $DATA(^RMPR(661.1,RMPRIEN,2,I,0))
SET DA=I
SET DA(1)=RMPRIEN
SET DIK="^RMPR(661.1,"_DA(1)_",2,"
DO ^DIK
+35 KILL DIK,DA,DA(1),I,^RMPR(661.1,RMPRIEN,2,"B")
End DoDot:3
KILL DIK,DA,DA(1)
+36 SET ^RMPR(661.1,RMPRIEN,2,RMPRIEN2,0)=RMPRVL
+37 SET CNTIEN=0
SET CNTIEN1=0
+38 FOR
SET CNTIEN=$ORDER(^RMPR(661.1,RMPRIEN,2,CNTIEN))
if CNTIEN'>0
QUIT
Begin DoDot:3
+39 SET CNTIEN1=CNTIEN1+1
End DoDot:3
+40 SET ^RMPR(661.1,RMPRIEN,2,0)="^661.18^"_CNTIEN1_U_CNTIEN1
+41 SET DIK="^RMPR(661.1,"
+42 SET DA=RMPRIEN
DO IX1^DIK
+43 SET RMPRFLD=""
End DoDot:2
+44 IF RMPRFLD=""
QUIT
+45 IF RMPRFLD'=.01
SET UPD(661.1,RMPRIEN_",",RMPRFLD)=RMPRVL
+46 SET CNT=CNT+1
End DoDot:1
+47 DO FILE^DIE("","UPD","ERROR")
+48 IF $DATA(ERROR("DIERR"))
SET RMPRMSG(1.1)="******* ERROR ENCOUNTERED*******"
+49 SET XMDUZ=.5
+50 SET XMY("G.RMPR SERVER")=""
+51 SET XMY("VHACOPSASPIPReport@domain.ext")=""
+52 SET XMSUB="PSAS HCPCS Item Server Update "_$PIECE($$SITE^VASITE,U,2)
+53 SET RMPRMSG(1)="The National PSAS Item Server has been activated today by Prosthetics HQ."
+54 SET RMPRMSG(2)="Please print your HCPCS Mapping File."
+55 SET RMPRMSG(3)=""
+56 SET RMPRMSG(4)="This was activated by "_$PIECE(XMFROM,"@",1)
+57 SET RMPRMSG(5)=""
+58 SET XMTEXT="RMPRMSG("
+59 DO ^XMD
+60 GOTO EXIT
+61 QUIT
NOGO ;message not valid
+1 SET XMDUZ=.5
+2 SET XMY("G.RMPR SERVER")=""
+3 SET XMY("VHACOPSASPIPReport@domain.ext")=""
+4 SET XMSUB="**ERROR** Not Authorized HCPCS Item Server Update From "_$PIECE($$SITE^VASITE,U,2)
+5 SET RMPRMSG(1)="The National PSAS Item Server was unsuccessful today."
+6 SET RMPRMSG(2)="****ERROR**** Not Authorized!"
+7 SET RMPRMSG(3)=""
+8 SET RMPRMSG(4)="This was activated by "_XMFROM
+9 SET XMTEXT="RMPRMSG("
+10 DO ^XMD
+11 ;
EXIT ;common exit point
+1 SET XMSER="S."_XQSOP
SET XMZ=XQMSG
DO REMSBMSG^XMA1C
+2 KILL %,CNT,DA,DIK,ERROR,RMPRDL,RMPRFLD,RMPRIEN2,RMPRMSG,RMPRVL,RMPRWHN
+3 KILL UPD,XMDUZ,XMFROM,XMREC,XMRG,XMSUB,XMTEXT,XMY,RMPRIEN,RMPRDLM,CNTIEN,CNTIEN1
+4 KILL RMPRWHO,RMPRWHO1,RMPRWHO2,RMPRWHO3,XMSER,RMPRCHK,XMZ,XQMSG,XQSOP
+5 ;END
