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 Dec 13, 2024@02:32:35 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
