RMPR21 ;PHX/HNB/JLT - CREATE 1358 TRANSACTION, POST TO 2319 ;8/29/1994
;;3.0;PROSTHETICS;**12,41,62,199**;Feb 09, 1996;Build 2
;RVD patch #62 - pce api
;Per VHA Directive 10-93-142, this routine should not be modified.
K ^TMP($J,"RMPRPCE")
S PRCS("A")="Select OBLIGATION NUMBER: " D EN1^PRCS58 G:Y=-1 EXIT
S RMPROB=$P(Y,U,2) D BAL^RMPRPSC
ST S RMPRR="",(RMPRCT,R1,RMPRQT,RMPRTO,RMPRDS,RMPRIS,B2)=0,B1=1
W !,"This will Create"_$S('$D(RMPRF):" a NO FORM ",RMPRF=1:" a PSC 10-55 ",RMPRF=2:" a 10-2421 ",RMPRF=8:" an EYEGLASS 10-2914 ",1:" ALL OTHER ")
A S %=1 R "Do you wish to Continue" D YN^DICN G:%=1 EN1 G:%=0 H
K RMPROB G EXIT
EN1 D GETPAT^RMPRUTIL
G:'$D(RMPRDFN) EXT
K DIC,DINUM,DIC("DR")
S X=DT,DIC("DR")="1////^S X=RMPRDFN"
S DIC="^RMPR(664,",DIC(0)="AELQM",DLAYGO=664
K DD,DO
D FILE^DICN K DLAYGO,DIC Q:Y<0
S (RMPRK,RMPRA)=+Y
S DFN=RMPRDFN D DEM^VADPT
VIEW ;VIEW 10-2319
S RMPRBAC1=1 D ^RMPRPAT K RMPRBAC1 G:$D(RMPRKILL) KILL
I RMPRF=10 D EN2520^RMPRM G:'$D(RMPRF) KILL
I RMPRF=1!(RMPRF=10) S RMPRFLAG=1 D DIS^RMPRAP G:$D(RMPRDIE) KILL
S DIE="^RMPR(664,",DA=RMPRA
S RMPRDR=$S(RMPRF=9:"NOFORM",RMPRF=1:"[RMPR55]",RMPRF=8:"[RMPREYE]",RMPRF=2:"2421",RMPRF=10:"[RMPR 2520]",1:"NOFORM")
G:RMPRDR["2421" P24^RMPR21A
G:RMPRDR["NOFORM" COT^RMPR21A
G:RMPRDR["RMPREYE" EYE^RMPRPSC
CON K DR
S DR=RMPRDR D ^DIE G:'$P(^RMPR(664,RMPRA,0),U,4) KILL
CHK D CHK1
I 'FL W !!,$C(7),?5,"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",! G KILL
S $P(^RMPR(664,RMPRA,0),U,9)=DUZ
;I $D(DTOUT)!($D(Y(0))) W !,$C(7),$C(7),"Please Try Later!" G KILL
ASK ;POST TRANSACTION QUESTION
S %=2 W !!,"Are you ready to POST to IFCAP and 10-2319 NOW"
D YN^DICN G:%=1 FILE^RMPR21B G:$D(DTOUT) KILL
I %=0 W !,"This will Create a Daily Transaction in the 1358 Module of IFCAP,",!,"and Create an Entry on the Prosthetic 10-2319 Record." G ASK
DEL ;
I %=-1 S %=2 R !,"Do you want to Delete this Transaction" D YN^DICN I $D(DTOUT)!(%=1) S:$D(RMPRA) RMPRK=RMPRA G KILL
I %=0 W !!,"ENTER YES OR NO!!",$C(7) S %=-1 G DEL
D ^RMPRLI I RMPRX]"" G ASK
L W !!!,"Enter Item to Edit: " R X:DTIME G:'$T KILL
G:X["^"!(X="") ASK I X["?" D ZDSP^RMPR21A G L
S DIC="^RMPR(664,"_RMPRA_",1,",DIC(0)="EQMZ" D ^DIC
I +Y'>0 K DA,Y G L
S DA=+Y,DA(1)=RMPRA,DIE=DIC
;HCPCS code
S DR="8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";.01;16;1;14;3;2;4;7;S Y="""";@1;10;16;1;14;3;2;4;7"
;S DR=".01;1;14;16;8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";3;2;4;7;S Y="""";@1;10;3;2;4;7"
;HCPCS code
S:RMPRDR["RMPREYE" DR="8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";.01;16;1;3;2;4;7;S Y="""";@1;10;16;1;3;2;4;7" D ^DIE
;S:RMPRDR["RMPREYE" DR=".01;16;8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";1;3;2;4;7;S Y="""";@1;10;1;3;2;4;7" D ^DIE
D CHK
I '$D(FL) W !!,$C(7),?5,"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",! G KILL
S DIE="^RMPR(664,",DA=RMPRA,DR=11 D ^DIE G L
H W !,"This will create a transaction, post to IFCAP, and update the 2319 report",! G A
;
CHK1 ;CHECK FOR EXISTENCE OF ITEMS ON PURCHASING FORMS
S FL=1
I $D(^RMPR(664,RMPRA,1)) S (FL,RI)=0 F S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 Q:'$D(^(RI,0)) D
.S FL=1
.S RB=^RMPR(664,RMPRA,1,RI,0)
.I $P(RB,U,3)=""!($P(RB,U,4)="")!($P(RB,U,5)="")!($P(RB,U,9)="")!($P(RB,U,10)="") S FL=0 Q
.S DA(1)=RMPRA,DA=RI D CHKCPT^RMPR21A
Q
;
ERROR ;ERROR MESSAGE FOR FAILED POSTING
I $G(MSG)'="" W !,MSG,! ;Write error message, RMPR*3*199
W !,$C(7),?5,"***PLEASE CONTACT YOUR FISCAL SERVICE***",!,Y
KILL ;DELETE PURCHASING ENTRY
Q:'$D(RMPRK)
S DA=RMPRK,DIK="^RMPR(664," D ^DIK W !,$C(7),?20,"Deleted..." K RMPRDOD,RMPROB
I $D(RMPRWO),$D(^RMPR(664.2,+RMPRWO,0)) D K DIK
TMP .S DA=0
.F S DA=$O(^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA)) Q:$G(DA)'>0
.S DIK="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO
.D ^DIK
EXIT ;EXIT AND KILL VARIABLES. SET UP OBLIGATION NUMBER QUESTION
S DIR(0)="FAO",DIR("A")="Press ENTER to continue " D ^DIR ;Require user to hit enter, RMPR*3*199
D:'$D(DTOUT) LINK^RMPRS D KVAR^VADPT
I $G(RMPRF)=2419 S RMPRSF=RMPRF S RMPRSDA=RMPRDA,RMPRSA=RMPRA
EXT K RMPRFLAG,RMPRG,RD,RMPRPSC,RMPRCONT,RMPRSH,RMPRDS,RMPRTO,RMPRCT,RMPRQT,R1,B2,D1,RMPRI,%,B1,DA,DIC,DIK,PRCS,PRCSCPAN,RMPRIN,RMPRPC,RMPRAMIS,RMPRARD,RMPRCNT,RMPRIT,RMPRIT1,RMPRU,SR,TYPE,RAC,FL,RMPRCTK,PRCSIP,PQTY,FL1,RMPRNOB,HY,RMPRGO
K ^TMP($J,"RMPRPCE")
K RMPRDIE,RMPRDR,RMPRDES,DIE,RMPRSR,DR,DTOUT,RMPRDOB,RMPRSC,RMPRTRN,RMPRX,RMPRK,RMPR660,RMPRA,RMPRDFN,RMPRDIS,RMPRIS,RMPRNAM,RMPRR,RMPRS,RMPRSSN
K RMPRSSNE,RMPRT,RMPRTN,RMPRV,Y,LINE,RMPRUP,RMPRSR,RMPRPI,RI,RA,RMPRI1,RMPRDELN,RDP,Y,RMPRSER,NAME,RMTYP,RMCAT,RMSPE,MSG ;Clean up MSG variable - RMPR*3*199
I $D(RMPRWO),RMPRWO D POST^RMPR29U Q
I $D(RMPRDA) Q
I $D(RMPROB) D PRCS^RMPRPSC G:(X'="^")!(X'["^") ST
K RMPROB,RMPRF,PRC,PRCS,RBL,RDA,RVA,RX,RMPRKILL Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR21 4838 printed Apr 09, 2024@21:35:45 Page 2
RMPR21 ;PHX/HNB/JLT - CREATE 1358 TRANSACTION, POST TO 2319 ;8/29/1994
+1 ;;3.0;PROSTHETICS;**12,41,62,199**;Feb 09, 1996;Build 2
+2 ;RVD patch #62 - pce api
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
+4 KILL ^TMP($JOB,"RMPRPCE")
+5 SET PRCS("A")="Select OBLIGATION NUMBER: "
DO EN1^PRCS58
if Y=-1
GOTO EXIT
+6 SET RMPROB=$PIECE(Y,U,2)
DO BAL^RMPRPSC
ST SET RMPRR=""
SET (RMPRCT,R1,RMPRQT,RMPRTO,RMPRDS,RMPRIS,B2)=0
SET B1=1
+1 WRITE !,"This will Create"_$SELECT('$DATA(RMPRF):" a NO FORM ",RMPRF=1:" a PSC 10-55 ",RMPRF=2:" a 10-2421 ",RMPRF=8:" an EYEGLASS 10-2914 ",1:" ALL OTHER ")
A SET %=1
READ "Do you wish to Continue"
DO YN^DICN
if %=1
GOTO EN1
if %=0
GOTO H
+1 KILL RMPROB
GOTO EXIT
EN1 DO GETPAT^RMPRUTIL
+1 if '$DATA(RMPRDFN)
GOTO EXT
+2 KILL DIC,DINUM,DIC("DR")
+3 SET X=DT
SET DIC("DR")="1////^S X=RMPRDFN"
+4 SET DIC="^RMPR(664,"
SET DIC(0)="AELQM"
SET DLAYGO=664
+5 KILL DD,DO
+6 DO FILE^DICN
KILL DLAYGO,DIC
if Y<0
QUIT
+7 SET (RMPRK,RMPRA)=+Y
+8 SET DFN=RMPRDFN
DO DEM^VADPT
VIEW ;VIEW 10-2319
+1 SET RMPRBAC1=1
DO ^RMPRPAT
KILL RMPRBAC1
if $DATA(RMPRKILL)
GOTO KILL
+2 IF RMPRF=10
DO EN2520^RMPRM
if '$DATA(RMPRF)
GOTO KILL
+3 IF RMPRF=1!(RMPRF=10)
SET RMPRFLAG=1
DO DIS^RMPRAP
if $DATA(RMPRDIE)
GOTO KILL
+4 SET DIE="^RMPR(664,"
SET DA=RMPRA
+5 SET RMPRDR=$SELECT(RMPRF=9:"NOFORM",RMPRF=1:"[RMPR55]",RMPRF=8:"[RMPREYE]",RMPRF=2:"2421",RMPRF=10:"[RMPR 2520]",1:"NOFORM")
+6 if RMPRDR["2421"
GOTO P24^RMPR21A
+7 if RMPRDR["NOFORM"
GOTO COT^RMPR21A
+8 if RMPRDR["RMPREYE"
GOTO EYE^RMPRPSC
CON KILL DR
+1 SET DR=RMPRDR
DO ^DIE
if '$PIECE(^RMPR(664,RMPRA,0),U,4)
GOTO KILL
CHK DO CHK1
+1 IF 'FL
WRITE !!,$CHAR(7),?5,"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",!
GOTO KILL
+2 SET $PIECE(^RMPR(664,RMPRA,0),U,9)=DUZ
+3 ;I $D(DTOUT)!($D(Y(0))) W !,$C(7),$C(7),"Please Try Later!" G KILL
ASK ;POST TRANSACTION QUESTION
+1 SET %=2
WRITE !!,"Are you ready to POST to IFCAP and 10-2319 NOW"
+2 DO YN^DICN
if %=1
GOTO FILE^RMPR21B
if $DATA(DTOUT)
GOTO KILL
+3 IF %=0
WRITE !,"This will Create a Daily Transaction in the 1358 Module of IFCAP,",!,"and Create an Entry on the Prosthetic 10-2319 Record."
GOTO ASK
DEL ;
+1 IF %=-1
SET %=2
READ !,"Do you want to Delete this Transaction"
DO YN^DICN
IF $DATA(DTOUT)!(%=1)
if $DATA(RMPRA)
SET RMPRK=RMPRA
GOTO KILL
+2 IF %=0
WRITE !!,"ENTER YES OR NO!!",$CHAR(7)
SET %=-1
GOTO DEL
+3 DO ^RMPRLI
IF RMPRX]""
GOTO ASK
L WRITE !!!,"Enter Item to Edit: "
READ X:DTIME
if '$TEST
GOTO KILL
+1 if X["^"!(X="")
GOTO ASK
IF X["?"
DO ZDSP^RMPR21A
GOTO L
+2 SET DIC="^RMPR(664,"_RMPRA_",1,"
SET DIC(0)="EQMZ"
DO ^DIC
+3 IF +Y'>0
KILL DA,Y
GOTO L
+4 SET DA=+Y
SET DA(1)=RMPRA
SET DIE=DIC
+5 ;HCPCS code
+6 SET DR="8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";.01;16;1;14;3;2;4;7;S Y="""";@1;10;16;1;14;3;2;4;7"
+7 ;S DR=".01;1;14;16;8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";3;2;4;7;S Y="""";@1;10;3;2;4;7"
+8 ;HCPCS code
+9 if RMPRDR["RMPREYE"
SET DR="8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";.01;16;1;3;2;4;7;S Y="""";@1;10;16;1;3;2;4;7"
DO ^DIE
+10 ;S:RMPRDR["RMPREYE" DR=".01;16;8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=""@1"";1;3;2;4;7;S Y="""";@1;10;1;3;2;4;7" D ^DIE
+11 DO CHK
+12 IF '$DATA(FL)
WRITE !!,$CHAR(7),?5,"REQUIRED FIELDS DO NOT EXIST ON THIS FORM",!
GOTO KILL
+13 SET DIE="^RMPR(664,"
SET DA=RMPRA
SET DR=11
DO ^DIE
GOTO L
H WRITE !,"This will create a transaction, post to IFCAP, and update the 2319 report",!
GOTO A
+1 ;
CHK1 ;CHECK FOR EXISTENCE OF ITEMS ON PURCHASING FORMS
+1 SET FL=1
+2 IF $DATA(^RMPR(664,RMPRA,1))
SET (FL,RI)=0
FOR
SET RI=$ORDER(^RMPR(664,RMPRA,1,RI))
if RI'>0
QUIT
if '$DATA(^(RI,0))
QUIT
Begin DoDot:1
+3 SET FL=1
+4 SET RB=^RMPR(664,RMPRA,1,RI,0)
+5 IF $PIECE(RB,U,3)=""!($PIECE(RB,U,4)="")!($PIECE(RB,U,5)="")!($PIECE(RB,U,9)="")!($PIECE(RB,U,10)="")
SET FL=0
QUIT
+6 SET DA(1)=RMPRA
SET DA=RI
DO CHKCPT^RMPR21A
End DoDot:1
+7 QUIT
+8 ;
ERROR ;ERROR MESSAGE FOR FAILED POSTING
+1 ;Write error message, RMPR*3*199
IF $GET(MSG)'=""
WRITE !,MSG,!
+2 WRITE !,$CHAR(7),?5,"***PLEASE CONTACT YOUR FISCAL SERVICE***",!,Y
KILL ;DELETE PURCHASING ENTRY
+1 if '$DATA(RMPRK)
QUIT
+2 SET DA=RMPRK
SET DIK="^RMPR(664,"
DO ^DIK
WRITE !,$CHAR(7),?20,"Deleted..."
KILL RMPRDOD,RMPROB
+3 IF $DATA(RMPRWO)
IF $DATA(^RMPR(664.2,+RMPRWO,0))
Begin DoDot:1
TMP SET DA=0
+1 FOR
SET DA=$ORDER(^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA))
if $GET(DA)'>0
QUIT
+2 SET DIK="^RMPR(664.2,"_RMPRWO_",1,"
SET DA(1)=RMPRWO
+3 DO ^DIK
End DoDot:1
KILL DIK
EXIT ;EXIT AND KILL VARIABLES. SET UP OBLIGATION NUMBER QUESTION
+1 ;Require user to hit enter, RMPR*3*199
SET DIR(0)="FAO"
SET DIR("A")="Press ENTER to continue "
DO ^DIR
+2 if '$DATA(DTOUT)
DO LINK^RMPRS
DO KVAR^VADPT
+3 IF $GET(RMPRF)=2419
SET RMPRSF=RMPRF
SET RMPRSDA=RMPRDA
SET RMPRSA=RMPRA
EXT KILL RMPRFLAG,RMPRG,RD,RMPRPSC,RMPRCONT,RMPRSH,RMPRDS,RMPRTO,RMPRCT,RMPRQT,R1,B2,D1,RMPRI,%,B1,DA,DIC,DIK,PRCS,PRCSCPAN,RMPRIN,RMPRPC,RMPRAMIS,RMPRARD,RMPRCNT,RMPRIT,RMPRIT1,RMPRU,SR,TYPE,RAC,FL,RMPRCTK,PRCSIP,PQTY,FL1,RMPRNOB,HY,RMPRGO
+1 KILL ^TMP($JOB,"RMPRPCE")
+2 KILL RMPRDIE,RMPRDR,RMPRDES,DIE,RMPRSR,DR,DTOUT,RMPRDOB,RMPRSC,RMPRTRN,RMPRX,RMPRK,RMPR660,RMPRA,RMPRDFN,RMPRDIS,RMPRIS,RMPRNAM,RMPRR,RMPRS,RMPRSSN
+3 ;Clean up MSG variable - RMPR*3*199
KILL RMPRSSNE,RMPRT,RMPRTN,RMPRV,Y,LINE,RMPRUP,RMPRSR,RMPRPI,RI,RA,RMPRI1,RMPRDELN,RDP,Y,RMPRSER,NAME,RMTYP,RMCAT,RMSPE,MSG
+4 IF $DATA(RMPRWO)
IF RMPRWO
DO POST^RMPR29U
QUIT
+5 IF $DATA(RMPRDA)
QUIT
+6 IF $DATA(RMPROB)
DO PRCS^RMPRPSC
if (X'="^")!(X'["^")
GOTO ST
+7 KILL RMPROB,RMPRF,PRC,PRCS,RBL,RDA,RVA,RX,RMPRKILL
QUIT
