RMPR21.m

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 ---RMPR21   4838     printed  Feb 18, 2025@23:58:21                                                                                                                                                                                                      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