Routine: RMPR37

RMPR37 ;PHX/HNC,JLT-POST AN ECMS 2237 TO 10-2319 ;8/29/1994

 ;;3.0;PROSTHETICS;**6,34,35,41,62,130,185**;Feb 09, 1996;Build 19

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;RVD patch #62 - PCE interface

 ;    patch #130 - Routine temporarily removed from Prosthetics

 ;DDA patch #185 - Reinstated for eCMS/IFCAP purchase requests

 K ^TMP($J,"RMPRPCE")

 D DIV4^RMPRSIT G:$D(X) EXIT

OBL ;get obligation number

 S DIC("S")="I $P(^(0),U,4)>1&($P(^(0),U,4)<5)"

 S DIC(0)="EQZ",DIC="^PRCS(410,"

 S DIC("A")="Select OBLIGATION NUMBER: "

 K R410

 D ^PRCSDIC G:Y'>0 EXIT

 I $P(Y(0),U,2)="CA" W !!,$C(7),?5,"OBILIGATION TRANSACTION CANCELED",! G OBL

 S RMPR2237=$P(Y,"^",2)

 S %X=DIC_+Y_",",%Y="R410(" D %XY^%RCR K %X,%Y,DIC

 ; CHECK FOR eCMS ACTIONID

 S RMPREAID=$P(R410(1),U,8)

 S RMPRPO=$P(R410(4),U,5)

 I RMPRPO="" W !!,$C(7),?5,"**WARNING -- THIS 2237 DOES NOT HAVE AN IFCAP PURCHASE ORDER **",!

DSP ;display obligation line items

 K RIT,RIB D HOME^%ZIS W @IOF K RIT,FL,RD

DSP0 ;DISPLAY BUT WITHOUT CLEARING THE SCREEN.

 S (CTT,ITN,LCT,PCT)=0 F  S ITN=$O(R410("IT",ITN)) Q:ITN'>0  S LCT=LCT+1 D A^RMPR37A

 I LCT=PCT W !,"All lines of this 2237 have been posted.",! H 5 G OBL

ASK ;ask item to post

 S X=CTT D COMMA^%DTC

 W !?34,"TOTAL EST. COST:  ",X

 S X=$P(R410(4),U,3) D COMMA^%DTC

 W !?34,"OBLIGATED AMOUNT: ",X S D1=0 W !,"REMARKS:",!

 F  S D1=$O(R410("RM",D1)) Q:D1'>0  W !,R410("RM",D1,0)

 W !!,"VENDOR: ",$P(R410(2),U,1)

 K DIR

 S DIR("?")="Enter the Line Item # you wish to post."

 W ! S DIR(0)="N^1:"_LCT

 S DIR("A")="Please enter Line Item #"

 D ^DIR

 I '$D(DTOUT),'$D(DIRUT),$D(X) S (RMPRY,RZ)=X

 I $D(DTOUT)!($D(DIRUT))!(Y=-1) W !,"Please Try Later!" G OBL

 S RMPRIT=+Y,RMPREIID="" K X,Y,DA

 I $D(R410("IT",RMPRIT,4)) S RMPREIID=$P(R410("IT",RMPRIT,4),U,3)

 I RMPREIID="" S RMPREIID=RMPR2237_"-"_RMPRIT

 I $D(^RMPR(660,"EIID",RMPREIID)) W !!,"**  LINE ITEM UNIQUE ID "_RMPREIID_" has already been posted!  **",!! G DSP0

PAT ;get patient

 D GETPAT^RMPRUTIL G:'$D(RMPRDFN) KILL

 K DIR,DA S DIR(0)="660,2",DIR("B")="INITIAL ISSUE" D ^DIR G:$D(DIRUT) KILL S (RMTYPE,RMPRTYP)=Y K X,Y

 K DIR,DA S DIR(0)="660,62" D ^DIR G:$D(DIRUT) KILL S RMPRCAT=Y,RMPRSC="" K X,Y

 I RMPRCAT=4 K DIR,DA S DIR(0)="660,63" D ^DIR G:$D(DIRUT) KILL S RMPRSC=Y K X,Y

 S RMPR661="" I $P(R410("IT",RMPRIT,0),U,5)'="" S RMPR661=$O(^RMPR(661,"B",$P(R410("IT",RMPRIT,0),U,5),""))

 I RMPR661'="" S C=$P(^DD(660,4,0),U,2),Y=RMPR661 D Y^DIQ S RMPR661T=Y K C,Y

 I RMPR661'="" K DIR,DA S DIR(0)="660,4",DIR("A")="ITEM",DIR("B")=RMPR661T D ^DIR G:$D(DIRUT) KILL S RMPR661=+Y K X,Y

 I RMPR661="" K DIR,DA S DIR(0)="660,4",DIR("A")="ITEM" D ^DIR G:$D(DIRUT) KILL S RMPR661=+Y K X,Y

 K DIR,DA S DIR(0)="660,4.5" D ^DIR G:$D(DIRUT) KILL S RMPRHC=+Y K X,Y

 S RDA=RMPRHC_"^"_RMTYPE_"^C^"_660

 D CPT^RMPRCPTU(RDA)

 S RMPRV=$P(R410(2),U)

 S RMPRQTY=$S($D(R410("IT",RMPRIT,0)):$P(R410("IT",RMPRIT,0),U,2),1:1)

 K DIR,Y,X S DIR(0)="660,9^O" D ^DIR G:$D(DTOUT)!($D(DUOUT)) KILL S RMPRSN=Y K X,Y

 K DIR,Y,X S DIR(0)="660,21" D ^DIR G:$D(DTOUT)!($D(DUOUT)) KILL S RMPRLT=Y K X,Y

AB S %=1 R !,"Would you like to POST this request now" D YN^DICN

 G:%<0 KILL G:%=0 H G:%=1 POST G:%=2 KILL

POST W !," Posting Now ..."

 S DIC="^RMPR(660,",DIC(0)="AEQLM",DLAYGO=660,X=DT

 S DIC("DR")=".02////^S X=RMPRDFN"

 K DINUM,DD,DO D FILE^DICN K DLAYGO

 I Y=-1 W !!,"*** Request failed to post.  Please contact support. ***" H 10 G EXIT

 S ^RMPR(660,+Y,0)=DT_U_RMPRDFN_U_$P(R410(1),U)_U_RMPRTYP_"^^"_RMPR661_U_RMPRQTY_U_$P(R410("IT",RMPRIT,0),U,3)_U_$P($G(R410(3)),U,4)_U_RMPR("STA")_U_RMPRSN_U_DT_"^3^C^^"_($P(R410("IT",RMPRIT,0),U,7)*RMPRQTY)_"^^^^^^^^"_RMPRLT,RMPRA=+Y

 S ^RMPR(660,+Y,1)=$P(R410(0),U,1)_"^^^"_$G(RMPRHC)_"^^"_RMCPT

 S $P(^RMPR(660,+Y,0),U,27)=DUZ

 ; S two new eCMS ID fields

 S ^RMPR(660,+Y,5)="^"_RMPREAID_"^"_RMPREIID

 S ^RMPR(660,+Y,"AM")="^^"_RMPRCAT_U_RMPRSC

 K RMPRG L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT-99

 I '$D(RMPRG) S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)

 S ^RMPR(660,+Y,"AMS")=RMPRG

 Q:'$D(R410("IT"))  S D1=0 F  S D1=$O(R410("IT",RMPRIT,1,D1)) Q:D1'>0  S RZI(RMPRIT_D1)=R410("IT",RMPRIT,1,D1,0)

 S D1=0 F I=1:1 S D1=$O(RZI(D1)) Q:D1'>0  S ^RMPR(660,+Y,"DES",I,0)=RZI(D1)

 S:RMPREAID'="" ^RMPR(660,+Y,"DES",I,0)=" eCMS ACTIONUID is "_RMPREAID_"/ eCMS ITEMUID is "_RMPREIID

 S ^RMPR(660,+Y,"DES",0)="^660.028^"_I_U_I,DIK=DIC,(RMPR660,DA)=+Y

 D IX1^DIK

 W !?5,"Updated 10-2319 Record"

 ;added in patch #62

 S ^TMP($J,"RMPRPCE",660,RMPR660)=RMPRG_"^"_$G(RMPRDFN)

 D LINK^RMPRS

 G DSP

H W !,"Enter `Y` for YES if you want to post this request to the Patient's 10-2319 Record." G AB

 ;KILL VARS BUT RETURN TO DSP0, LINE SELECTION PROMPT

KILL W !,$C(7),"** Did Not POST 2237 to Veterans 2319 Record! **" K RMPRIT,RMPREIID,RMTYPE,RMPRTYP,RMPRCAT,RMPRSC,RMPRHC,RMPRV,RMPRQTY,RMPRSN G DSP0

 ;KILL VARS AND EXIT

EXIT K ITN,RZZZ,RG,D1,DIK,DIR,DIRUT,DTOUT,DUOUT,I,RMPRCNT,RMPRSEL,DA,RMPRA,RMPRDFN,UN,X,X2,R410,CTT,RTN,RMPRV,RMPRQTY,DIC,Y,RMPRTYP,PRC,RMPRIT,RMPRCAT,RMPRSC,RD,RC,RIT,RIN,RZ,RT,RF,RE,RNI,CI,AZL,RIB,RMPRSN

 K RMPR660,RMPR661,RMCHK,RMPREAID,LCT,PCT,RMPR2237,RMPRPO

 K ^TMP($J,"RMPRPCE")

 K PRCSIP,RAT,RZI,KI,C1,GI,KK,RB,RI,RJ,RXX,RMPRHC,RMPRY,RMPRDOB,RMPRNAM,RMPRSSN,RMPRG,N,RMCPT,RMTYPE,RDA,RMPRCNUM,RMPRSSNE,RRX,PRCFLAG,TYPE Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR37   5420     printed  Mar 13, 2025@21:37:21                                                                                                                                                                                                      Page 2

RMPR37    ;PHX/HNC,JLT-POST AN ECMS 2237 TO 10-2319 ;8/29/1994

 +1       ;;3.0;PROSTHETICS;**6,34,35,41,62,130,185**;Feb 09, 1996;Build 19

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ;RVD patch #62 - PCE interface

 +5       ;    patch #130 - Routine temporarily removed from Prosthetics

 +6       ;DDA patch #185 - Reinstated for eCMS/IFCAP purchase requests

 +7       ;

 +8        KILL ^TMP($JOB,"RMPRPCE")

 +9        DO DIV4^RMPRSIT

           if $DATA(X)

               GOTO EXIT

OBL       ;get obligation number

 +1        SET DIC("S")="I $P(^(0),U,4)>1&($P(^(0),U,4)<5)"

 +2        SET DIC(0)="EQZ"

           SET DIC="^PRCS(410,"

 +3        SET DIC("A")="Select OBLIGATION NUMBER: "

 +4        KILL R410

 +5        DO ^PRCSDIC

           if Y'>0

               GOTO EXIT

 +6        IF $PIECE(Y(0),U,2)="CA"

               WRITE !!,$CHAR(7),?5,"OBILIGATION TRANSACTION CANCELED",!

               GOTO OBL

 +7        SET RMPR2237=$PIECE(Y,"^",2)

 +8        SET %X=DIC_+Y_","

           SET %Y="R410("

           DO %XY^%RCR

           KILL %X,%Y,DIC

 +9       ; CHECK FOR eCMS ACTIONID

 +10       SET RMPREAID=$PIECE(R410(1),U,8)

 +11       SET RMPRPO=$PIECE(R410(4),U,5)

 +12       IF RMPRPO=""

               WRITE !!,$CHAR(7),?5,"**WARNING -- THIS 2237 DOES NOT HAVE AN IFCAP PURCHASE ORDER **",!

DSP       ;display obligation line items

 +1        KILL RIT,RIB

           DO HOME^%ZIS

           WRITE @IOF

           KILL RIT,FL,RD

DSP0      ;DISPLAY BUT WITHOUT CLEARING THE SCREEN.

 +1        SET (CTT,ITN,LCT,PCT)=0

FOR

               SET ITN=$ORDER(R410("IT",ITN))

               if ITN'>0

                   QUIT

               SET LCT=LCT+1

               DO A^RMPR37A

 +2        IF LCT=PCT

               WRITE !,"All lines of this 2237 have been posted.",!

               HANG 5

               GOTO OBL

ASK       ;ask item to post

 +1        SET X=CTT

           DO COMMA^%DTC

 +2        WRITE !?34,"TOTAL EST. COST:  ",X

 +3        SET X=$PIECE(R410(4),U,3)

           DO COMMA^%DTC

 +4        WRITE !?34,"OBLIGATED AMOUNT: ",X

           SET D1=0

           WRITE !,"REMARKS:",!

 +5        FOR

               SET D1=$ORDER(R410("RM",D1))

               if D1'>0

                   QUIT

               WRITE !,R410("RM",D1,0)

 +6        WRITE !!,"VENDOR: ",$PIECE(R410(2),U,1)

 +7        KILL DIR

 +8        SET DIR("?")="Enter the Line Item # you wish to post."

 +9        WRITE !

           SET DIR(0)="N^1:"_LCT

 +10       SET DIR("A")="Please enter Line Item #"

 +11       DO ^DIR

 +12       IF '$DATA(DTOUT)

               IF '$DATA(DIRUT)

                   IF $DATA(X)

                       SET (RMPRY,RZ)=X

 +13       IF $DATA(DTOUT)!($DATA(DIRUT))!(Y=-1)

               WRITE !,"Please Try Later!"

               GOTO OBL

 +14       SET RMPRIT=+Y

           SET RMPREIID=""

           KILL X,Y,DA

 +15       IF $DATA(R410("IT",RMPRIT,4))

               SET RMPREIID=$PIECE(R410("IT",RMPRIT,4),U,3)

 +16       IF RMPREIID=""

               SET RMPREIID=RMPR2237_"-"_RMPRIT

 +17       IF $DATA(^RMPR(660,"EIID",RMPREIID))

               WRITE !!,"**  LINE ITEM UNIQUE ID "_RMPREIID_" has already been posted!  **",!!

               GOTO DSP0

PAT       ;get patient

 +1        DO GETPAT^RMPRUTIL

           if '$DATA(RMPRDFN)

               GOTO KILL

 +2        KILL DIR,DA

           SET DIR(0)="660,2"

           SET DIR("B")="INITIAL ISSUE"

           DO ^DIR

           if $DATA(DIRUT)

               GOTO KILL

           SET (RMTYPE,RMPRTYP)=Y

           KILL X,Y

 +3        KILL DIR,DA

           SET DIR(0)="660,62"

           DO ^DIR

           if $DATA(DIRUT)

               GOTO KILL

           SET RMPRCAT=Y

           SET RMPRSC=""

           KILL X,Y

 +4        IF RMPRCAT=4

               KILL DIR,DA

               SET DIR(0)="660,63"

               DO ^DIR

               if $DATA(DIRUT)

                   GOTO KILL

               SET RMPRSC=Y

               KILL X,Y

 +5        SET RMPR661=""

           IF $PIECE(R410("IT",RMPRIT,0),U,5)'=""

               SET RMPR661=$ORDER(^RMPR(661,"B",$PIECE(R410("IT",RMPRIT,0),U,5),""))

 +6        IF RMPR661'=""

               SET C=$PIECE(^DD(660,4,0),U,2)

               SET Y=RMPR661

               DO Y^DIQ

               SET RMPR661T=Y

               KILL C,Y

 +7        IF RMPR661'=""

               KILL DIR,DA

               SET DIR(0)="660,4"

               SET DIR("A")="ITEM"

               SET DIR("B")=RMPR661T

               DO ^DIR

               if $DATA(DIRUT)

                   GOTO KILL

               SET RMPR661=+Y

               KILL X,Y

 +8        IF RMPR661=""

               KILL DIR,DA

               SET DIR(0)="660,4"

               SET DIR("A")="ITEM"

               DO ^DIR

               if $DATA(DIRUT)

                   GOTO KILL

               SET RMPR661=+Y

               KILL X,Y

 +9        KILL DIR,DA

           SET DIR(0)="660,4.5"

           DO ^DIR

           if $DATA(DIRUT)

               GOTO KILL

           SET RMPRHC=+Y

           KILL X,Y

 +10       SET RDA=RMPRHC_"^"_RMTYPE_"^C^"_660

 +11       DO CPT^RMPRCPTU(RDA)

 +12       SET RMPRV=$PIECE(R410(2),U)

 +13       SET RMPRQTY=$SELECT($DATA(R410("IT",RMPRIT,0)):$PIECE(R410("IT",RMPRIT,0),U,2),1:1)

 +14       KILL DIR,Y,X

           SET DIR(0)="660,9^O"

           DO ^DIR

           if $DATA(DTOUT)!($DATA(DUOUT))

               GOTO KILL

           SET RMPRSN=Y

           KILL X,Y

 +15       KILL DIR,Y,X

           SET DIR(0)="660,21"

           DO ^DIR

           if $DATA(DTOUT)!($DATA(DUOUT))

               GOTO KILL

           SET RMPRLT=Y

           KILL X,Y

AB         SET %=1

           READ !,"Would you like to POST this request now"

           DO YN^DICN

 +1        if %<0

               GOTO KILL

           if %=0

               GOTO H

           if %=1

               GOTO POST

           if %=2

               GOTO KILL

POST       WRITE !," Posting Now ..."

 +1        SET DIC="^RMPR(660,"

           SET DIC(0)="AEQLM"

           SET DLAYGO=660

           SET X=DT

 +2        SET DIC("DR")=".02////^S X=RMPRDFN"

 +3        KILL DINUM,DD,DO

           DO FILE^DICN

           KILL DLAYGO

 +4        IF Y=-1

               WRITE !!,"*** Request failed to post.  Please contact support. ***"

               HANG 10

               GOTO EXIT

 +5        SET ^RMPR(660,+Y,0)=DT_U_RMPRDFN_U_$PIECE(R410(1),U)_U_RMPRTYP_"^^"_RMPR661_U_RMPRQTY_U_$PIECE(R410("IT",RMPRIT,0),U,3)_U_$PIECE($GET(R410(3)),U,4)_U_RMPR("STA")_U_RMPRSN_U_DT_"^3^C^^"_($PIECE(R410("IT",RMPRIT,0),U,7)*RMPRQTY)_"^^^^^^^^"_RMPRLT

           SET RMPRA=+Y

 +6        SET ^RMPR(660,+Y,1)=$PIECE(R410(0),U,1)_"^^^"_$GET(RMPRHC)_"^^"_RMCPT

 +7        SET $PIECE(^RMPR(660,+Y,0),U,27)=DUZ

 +8       ; S two new eCMS ID fields

 +9        SET ^RMPR(660,+Y,5)="^"_RMPREAID_"^"_RMPREIID

 +10       SET ^RMPR(660,+Y,"AM")="^^"_RMPRCAT_U_RMPRSC

 +11       KILL RMPRG

           LOCK +^RMPR(669.9,RMPRSITE,0):999

           IF $TEST=0

               SET RMPRG=DT-99

 +12       IF '$DATA(RMPRG)

               SET RMPRG=$PIECE(^RMPR(669.9,RMPRSITE,0),U,7)

               SET RMPRG=RMPRG-1

               SET $PIECE(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG

               LOCK -^RMPR(669.9,RMPRSITE,0)

 +13       SET ^RMPR(660,+Y,"AMS")=RMPRG

 +14       if '$DATA(R410("IT"))

               QUIT

           SET D1=0

FOR

               SET D1=$ORDER(R410("IT",RMPRIT,1,D1))

               if D1'>0

                   QUIT

               SET RZI(RMPRIT_D1)=R410("IT",RMPRIT,1,D1,0)

 +15       SET D1=0

           FOR I=1:1

               SET D1=$ORDER(RZI(D1))

               if D1'>0

                   QUIT

               SET ^RMPR(660,+Y,"DES",I,0)=RZI(D1)

 +16       if RMPREAID'=""

               SET ^RMPR(660,+Y,"DES",I,0)=" eCMS ACTIONUID is "_RMPREAID_"/ eCMS ITEMUID is "_RMPREIID

 +17       SET ^RMPR(660,+Y,"DES",0)="^660.028^"_I_U_I

           SET DIK=DIC

           SET (RMPR660,DA)=+Y

 +18       DO IX1^DIK

 +19       WRITE !?5,"Updated 10-2319 Record"

 +20      ;added in patch #62

 +21       SET ^TMP($JOB,"RMPRPCE",660,RMPR660)=RMPRG_"^"_$GET(RMPRDFN)

 +22       DO LINK^RMPRS

 +23       GOTO DSP

H          WRITE !,"Enter `Y` for YES if you want to post this request to the Patient's 10-2319 Record."

           GOTO AB

 +1       ;KILL VARS BUT RETURN TO DSP0, LINE SELECTION PROMPT

KILL       WRITE !,$CHAR(7),"** Did Not POST 2237 to Veterans 2319 Record! **"

           KILL RMPRIT,RMPREIID,RMTYPE,RMPRTYP,RMPRCAT,RMPRSC,RMPRHC,RMPRV,RMPRQTY,RMPRSN

           GOTO DSP0

 +1       ;KILL VARS AND EXIT

EXIT       KILL ITN,RZZZ,RG,D1,DIK,DIR,DIRUT,DTOUT,DUOUT,I,RMPRCNT,RMPRSEL,DA,RMPRA,RMPRDFN,UN,X,X2,R410,CTT,RTN,RMPRV,RMPRQTY,DIC,Y,RMPRTYP,PRC,RMPRIT,RMPRCAT,RMPRSC,RD,RC,RIT,RIN,RZ,RT,RF,RE,RNI,CI,AZL,RIB,RMPRSN

 +1        KILL RMPR660,RMPR661,RMCHK,RMPREAID,LCT,PCT,RMPR2237,RMPRPO

 +2        KILL ^TMP($JOB,"RMPRPCE")

 +3        KILL PRCSIP,RAT,RZI,KI,C1,GI,KK,RB,RI,RJ,RXX,RMPRHC,RMPRY,RMPRDOB,RMPRNAM,RMPRSSN,RMPRG,N,RMCPT,RMTYPE,RDA,RMPRCNUM,RMPRSSNE,RRX,PRCFLAG,TYPE

           QUIT

RMPR37.m