RMPR4E21 ;PHX/HNC - CLOSE OUT PURCHASE CARD TRANSACTION; MAR 1, 1996
;;3.0;PROSTHETICS;**3,12,26,28,30,34,41,45,62,111,78,114,118,133,137,182,198,211**;Feb 09, 1996;Build 10
;TH Patch #78 - 08/04/03 - Add shipment date. Call routine ^RMPR4E23
;RVD patch #62 - PCE processing and link to suspense
;
;RMPR*3.0*182 Add Lot, Model and Contract number to reconciliation editing
; Modify exit kill for ^TMP("RM") to be set to $J to
; prevent killing other user's work area.
;
;I '$D(^PRC(440.5,"H",DUZ)) W !!,"You are not an authorized Purchase Card User, CONTACT FISCAL!" Q
START I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X)
CL K ^TMP($J,"RMPRPCE")
K DIC S DIC="664",DIC(0)="AEQM",DIC("W")="D EN2^RMPR4D1",DIC("A")="Select PATIENT: "
S DIC("S")="I $D(^(4)) I ('$P(^(0),U,8)&'$P(^(0),U,5)),($P(^(0),U,14)=RMPR(""STA""))"
W !!,"You may also make a selection by Purchase Card Transaction"
W !,"(Example, PO number), or Bank Authorization Number (6 digit number).",!
D ^DIC S (DA,RMPRA)=+Y I Y=-1 G EXIT
K DIC G:$P(^RMPR(664,RMPRA,0),U,8) M4 G:$P(^(0),U,5) M6
L +^RMPR(664,RMPRA,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT
;get amis grouper number RGRP1
S RGRP=0,RGRP1=""
S RGRP=$O(^RMPR(664,RMPRA,1,RGRP)) G:'RGRP BRK S RGRPP=$P($G(^RMPR(664,RMPRA,1,RGRP,0)),U,13) I 'RGRPP W !!,$C(7),"ERROR** This transaction was not posted to 2319, please contact your IRM..",!! S DIR(0)="E" D ^DIR G EXIT
S RGRP1=$P($G(^RMPR(660,RGRPP,"AMS")),U,1)
S (RMPRDFN,DFN)=$P(^RMPR(664,RMPRA,0),U,2),RMPRWO=$P(^(0),U,15),RMPRDA=$P(^(0),U,17)
D DEM^VADPT S RMPRSSNE=VA("PID"),RMPRSSN=+VADM(2),RMPRNAM=VADM(1) K VADM
;set original value before close-out
K ^TMP("RM",$J),RM(RMPRA),RHCED S RMPRF=2
K %X,%Y S %X="^RMPR(664,RMPRA,",%Y="^TMP("_"""RM"""_",$J,RMPRA," D %XY^%RCR
S RM(RMPRA,0)=$G(^RMPR(664,RMPRA,0)),RM(RMPRA,2)=$G(^(2)),RM(RMPRA,4)=$G(^(4))
S RMPER=$P(RM(RMPRA,2),U,6),RMBAN=$P(RM(RMPRA,4),U,2),RMSHI=$P(RM(RMPRA,0),U,11),RMSHIEN=$P(RM(RMPRA,0),U,12)
S:RMSHI=""!(RMSHI+0=0) RMSHI=0
;added by #62
;collect all items and previous linkage to suspense.
I $G(RMSHIEN) S:'$D(^RMPR(660,RMSHIEN,10)) RM60LINK(RMSHIEN)=""
D COL^RMPRPCEL
;
L ;**** ask for final posting *****************************************
D ^RMPR4LI N DIR K RFLG
S DIR("A")="Ready to Reconcile and Close-Out Transaction",DIR("B")="NO",DIR(0)="Y"
S DIR("?")="You may now Close-out and Post this Transaction. Please answer Yes or No."
D ^DIR I Y["^"!($D(DTOUT)) W !,"Transaction NOT Closed-Out!" S:$D(^TMP("RM",$J)) RFLG=1 G:$D(RFLG) POST1 G KTMP
I Y=1 G POST1
;***add/edit transaction**********************************************
L1 K DIR S DIR(0)="FO",DIR("A")="Select ITEM"
S DIR("?")="^S RFL=1 D ZDSP^RMPR421A"
D ^DIR G:(Y="^")!(Y="") DS G:$D(DTOUT) L
G:$D(DIRUT)&($D(^RMPR(664,RMPRA,1))) L
S DIC=661,DIC(0)="ENMZ" D ^DIC I +Y'>0 W !,"** No Item selected.." G DS
G:$D(DTOUT)!$D(DUOUT) L
D PROC G L1
;
;RMPR*3.0*211 changes; called by "DEL" node code on the .01 field of the #664.02 multiple
IC() ;DETERMINE NUMBER OF ITEMS FOR PURCHASING AND CLOSE-OUT
N RMPRICS,RMPRIC
S RMPRICS=0 I $D(RMPRA) F S RMPRICS=$O(^RMPR(664,RMPRA,1,RMPRICS)) Q:RMPRICS'>0 S RMPRIC=$G(RMPRIC)+1
Q:RMPRIC'=1 RMPRIC
IC1 ;DISPLAY TEXT FOR DELETE (@) ATTEMPTS FOR MULTIPLES OF ONLY 1 ITEM
W !!,"You may not delete the single remaining item in the BILLING ITEM"
W !,"sub-file. If you want to change the existing item to a different"
W !,"item, add the new item and then delete the desired item.",!!
S X="?"
Q RMPRIC
;End of RMPR*3.0*211 changes
;***process items*******************************************************
PROC N NEW S HY=+Y I $D(^RMPR(664,RMPRA,1,"B",+Y)) S DA=$O(^RMPR(664,RMPRA,1,"B",+Y,0)) G CHK
FILE S Y=HY,NUM=$P(^RMPR(664,RMPRA,1,0),U,3)+1,$P(^(0),U,3)=NUM,$P(^(0),U,4)=$P(^(0),U,4)+1,^RMPR(664,RMPRA,1,NUM,0)=+Y,DA=NUM,^RMPR(664,RMPRA,1,"B",+Y,NUM)="" S NEW=1
ENT K DR,DQ S DA(1)=RMPRA,DIE="^RMPR(664,"_RMPRA_",1,"
;S DR=$S($D(NEW):"",1:".01;")
I '$D(NEW),($P(^RMPR(664,RMPRA,1,DA,0),U,7)="") S $P(^(0),U,7)=$P(^(0),U,3)
S:'$D(NEW) RMDACA=$P(^RMPR(664,RMPRA,1,DA,0),U,13)
S R4DA=DA
S DR="8;S RMTYPE=$P(^RMPR(664,RMPRA,1,R4DA,0),U,9);9;.01;"
S DR=DR_"16R;1;14;17;13;15.4;15;15.6;3R;" ;RMPR*3.0*182
I $D(NEW) S DR=DR_"2R~UNIT COST;"
E S DR=DR_"6R;",RHCNEW=$P($G(^RMPR(664,RMPRA,1,R4DA,0)),U,16)
S DR=DR_"4R~UNIT OF ISSUE;7;11////C" D ^DIE
I $D(NEW) S:$G(DA) ^TMP("RM",$J,"N",R4DA)=$G(^RMPR(664,RMPRA,1,R4DA,0))
E S:'$G(DA)&(RMDACA) ^TMP("RM",$J,"C",RMDACA)="" I $G(DA) S ^TMP("RM",$J,"E",DA)=$G(^RMPR(664,RMPRA,1,DA,0)),RHCOLD=$P(^RMPR(664,RMPRA,1,DA,0),U,16),RD660=$P(^(0),U,13) I RHCNEW'=RHCOLD D
.S RHCED=1
.I $D(RD660)&(RD660) S DIE="^RMPR(660,",DA=RD660,DR="4.5///^S X=$G(RHCOLD)" D ^DIE
I $D(R4DA),$P($G(^RMPR(664,RMPRA,1,R4DA,0)),U,10)=4 S DA=R4DA,DR=10 D ^DIE
;check for Type of Transaction and update the cpt modifier.
I $D(R4DA),$D(RMTYPE) S RDATA=RMTYPE_"^"_RMPRA_"^"_R4DA D CHKCPT^RMPR4UTL(RDATA)
Q:$D(DTOUT) K NUM,R4DA,DA,Y,DR,RD660,RHCOLD,RHCNEW,DIE,RDATA,RMTYPE Q
CHK ;ADD DUPLICATE LINE ITEM
K DIR,Y S DIR(0)="S^Y:YES;N:NO",DIR("A")="DO YOU WANT TO ADD A DUPLICATE ITEM?",DIR("B")="NO" D ^DIR Q:$D(DIRUT)!($D(DTOUT)) I (X["Y")!(X["y") G FILE
S RD=0 F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD=RD+1
LKP I RD>1 D Q:$D(DIRUT)!$D(DTOUT) I '$D(RD(+Y)) W $C(7) G LKP
.F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD(RDA)=^RMPR(664,RMPRA,1,RDA,0) W !?5,RDA,?10,$P(^PRC(441,$P(^RMPR(661,$P(RD(RDA),U),0),U),0),U,2)," $",$S($P(RD(RDA),U,7)'="":$P(RD(RDA),U,7),1:$P(RD(RDA),U,3))
.K DIR,Y S DIR(0)="N" D ^DIR I +Y S DA=+Y
G ENT
;
DS ;**** update shipping cost, % discount and bank authorization ********
S (RMPERF,RMBANF,RMSHIF)=0
I $P(^RMPR(664,RMPRA,0),U,11)="",$P(^(0),U,10) S $P(^(0),U,11)=$P(RM(RMPRA,0),U,10)
S DA=RMPRA,DIE="^RMPR(664,",DR="12;17;26" D ^DIE
S:+$P(^RMPR(664,RMPRA,0),U,11)=0 $P(^(0),U,11)=0
I RMPER'=$P(^RMPR(664,RMPRA,2),U,6) S RMPERF=1
I RMBAN'=$P(^RMPR(664,RMPRA,4),U,2) S RMBANF=1
I RMSHI'=$P(^RMPR(664,RMPRA,0),U,11)!($P(^(0),U,11)=0&$P(^(0),U,12)) S RMSHIF=1
CHK1 ;delete imcomplete items
S DIK="^RMPR(664,"_RMPRA_",1,",DA(1)=RMPRA F I=0:0 S I=$O(^RMPR(664,RMPRA,1,I)) Q:I'>0 S RMPRI=$G(^(I,0)) I $P(RMPRI,U,3)=""!($P(RMPRI,U,4)="")!($P(RMPRI,U,5)="") S DA=I D ^DIK
G L ;go back to select ITEM
;*************************************************************
POST1 ;SET AMOUNT FOR IFCAP AMENDMENT.
S (R1,RMPR("AMT"),AMT,DCT,RMPRTO)=0
I $D(^RMPR(664,RMPRA,2)),$P(^(2),U,6) S DCT=$P(^(2),U,6),DCT=DCT/100
F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 D
.N RMACT
.S RMX=$G(^RMPR(664,RMPRA,1,RI,0)),RMACT=$P(RMX,U,7),RMQTY=$P(RMX,U,4)
.I DCT S RMTOT=$S(RMACT=0!(RMACT>0):RMACT-$J(RMACT*DCT,0,2)*RMQTY,1:$P(RMX,U,3)-$J($P(RMX,U,3)*DCT,0,2)*RMQTY)
.I 'DCT S RMTOT=$S(RMACT=0!(RMACT>0):RMACT*RMQTY,1:$P(RMX,U,3)*RMQTY)
.S RMPR("AMT")=RMPR("AMT")+RMTOT,RMPRTO=RMPR("AMT")
S RMPRSH=$S($P(^RMPR(664,RMPRA,0),U,11)=0:0,$P(^RMPR(664,RMPRA,0),U,11):$P(^(0),U,11),$P(^RMPR(664,RMPRA,0),U,10):$P(^(0),U,10),1:"")
D CHECK^RMPRCT I '$D(RMPRTO) W !,"***** NOT CLOSED-OUT !!!!" G KTMP
;**************************************************************
;check 4;3,2;8&2;9&4;6 call PRCH7C if needed
;if total amount has not changed, then don't need to call ammend
;if it is an early record with no ifcap order then don't call ammend
;set the reprint flag
I $FN($P(^RMPR(664,RMPRA,4),U,3),"P",2)'=$FN(RMPRTO+RMPRSH,"P",2)&($P(^(2),U,9)="")!($P(^(2),U,9)'="")&($FN($P(^(2),U,9),"P",2)'=$FN(RMPRTO+RMPRSH,"P",2)) D I (X=0)&'$D(^TMP("RM",$J)) W !!,"**** NOT CLOSED-OUT!! ****" G KTMP
.;call IFCAP AMMEND
.S RMPR442=$P(^RMPR(664,RMPRA,4),U,6) I RMPR442="" Q
.D AMEND^PRCH7C(RMPR442,RMPRTO+RMPRSH)
.I X=1 S $P(^RMPR(664,RMPRA,2),U,8)=DUZ,$P(^RMPR(664,RMPRA,2),U,9)=RMPRTO+RMPRSH,$P(^RMPR(664,RMPRA,2),U,10)=1
.I X'=1 S $P(^RMPR(664,RMPRA,2),U,10)=""
;do posting to 660
I $D(^TMP("RM",$J))!$G(RMSHIF)!$G(RMPERF)!$G(RMBANF) D POST2^RMPR4M
I $D(RMPRWO),$D(^RMPR(664.2,+RMPRWO,0)) S $P(^("AM"),U,2)=1 S $P(^RMPR(664.2,+RMPRWO,0),U,7)=$P(^(0),U,7)+RMPRSH D DA0^RMPR29M(RMPRDA,RMPRA),POST^RMPR29U
G:$D(RFLG) EXIT
;go to exit in above line if not close-out.
;close-out remarks
W ! S DIE="^RMPR(664,",DA=RMPRA,DR="8.1" D ^DIE S RMPRCC=$P($G(^RMPR(664,RMPRA,2)),U,3)
F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 I $D(^(R1,0)) D
.N RM660
.S RM660=$P($G(^(0)),U,13) I RM660,$P($G(^RMPR(660,RM660,0)),U,18)'[RMPRCC S $P(^(0),U,18)=$P(^(0),U,18)_" "_RMPRCC
;
EX ;***reindex record in 664 here
L -^RMPR(664,RMPRA,0)
;IFCAP final charge payment
S RMPR442=$P(^RMPR(664,RMPRA,4),U,6) ;don't call recon if it is an early record, no ifcap order.
I $G(RMPR442),'$D(^PRC(442,RMPR442,0)) D M442 Q ;RMPR*3.0*198 when file #442 does not exist a reconcile cannot occur
D:RMPR442'="" RECON^PRCH7C(RMPR442,DUZ)
I (X=0)&(RMPR442'="") W !!,"**** TRANSACTION NOT CLOSED-OUT!! ****" G EX1
S $P(^RMPR(664,RMPRA,4),U,4)=RMPRTO+RMPRSH
;set close out date
D NOW^%DTC S $P(^RMPR(664,RMPRA,0),U,8)=%
;set closed by
S $P(^RMPR(664,RMPRA,2),U,7)=DUZ,DA=$P(^RMPR(664,RMPRA,0),U,12)
I DA'="" S $P(^RMPR(660,DA,0),U,12)=%,DIK="^RMPR(660," D IX1^DIK
S RMPR660=0,DA="",DIK="^RMPR(660,"
F S RMPR660=$O(^RMPR(664,RMPRA,1,RMPR660)) Q:RMPR660'>0 D
.;get pointer from item mult
.S DA=$P(^RMPR(664,RMPRA,1,RMPR660,0),U,13)
.;set delivery date
.I DA'="" S $P(^RMPR(660,DA,0),U,12)=DT D IX1^DIK
.;Patch #78 - Get IFCAP Transaction Date and prompt for Shipment Date
.I DA'="" S SKPSHDT=1 D ^RMPR4E23 K SKPSHDT
EX1 ;
I $D(RM60LINK) D
. F I=0:0 S I=$O(RM60LINK(I)) Q:I'>0 D
.. I '$D(^RMPR(660,I,0)) K RM60LINK(I)
;added by #62
D:$D(RM68FG)=1 AUTO^RMPRPCEL D:$D(RM68FG)>1 MAN^RMPRPCEL
;
D EXIT
W !!,"Enter Next Transaction to Close-out, or <RETURN> to continue."
G CL
;
EXIT ;KILL VARIABLES AND EXIT ROUTINE
L:$D(RMPRA) -^RMPR(664,RMPRA,0)
K ^TMP($J),^TMP("RM",$J) ;RMPR*3.0*182
K RGRP,RGRP1,RGRPP,RMBAN,RMBANF
N RMPR,RMPRSITE D KILL^XUSCLEAN
Q
;
KTMP S DIK="^RMPR(664,"_RMPRA_",1,",DA(1)=RMPRA F I=0:0 S I=$O(^TMP("RM",$J,"N",I)) Q:I'>0 S DA=I D ^DIK
S %X="^TMP("_"""RM"""_",$J,RMPRA,",%Y="^RMPR(664,RMPRA," D %XY^%RCR G EX1
BRK W !,$C(7),"INCOMPLETE RECORD..file 664..entry..",RMPRA,"...PLEASE CONTACT YOUR IRM or CANCEL THIS ENTRY!!!" G EX1
UNK W !,$C(7),"UNKNOWN 2319 RECORD TO UPDATE, 2319 NOT UPDATED!" G EXIT
M4 W !,$C(7),"This Transaction has already been CLOSED!" G EXIT
M6 W !,$C(7),"This Transaction has been CANCELED!" G EXIT
M442 W !,$C(7),"This order cannot be Reconciled. The Purchase Order no longer exists." G EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR4E21 10757 printed Dec 13, 2024@02:32:44 Page 2
RMPR4E21 ;PHX/HNC - CLOSE OUT PURCHASE CARD TRANSACTION; MAR 1, 1996
+1 ;;3.0;PROSTHETICS;**3,12,26,28,30,34,41,45,62,111,78,114,118,133,137,182,198,211**;Feb 09, 1996;Build 10
+2 ;TH Patch #78 - 08/04/03 - Add shipment date. Call routine ^RMPR4E23
+3 ;RVD patch #62 - PCE processing and link to suspense
+4 ;
+5 ;RMPR*3.0*182 Add Lot, Model and Contract number to reconciliation editing
+6 ; Modify exit kill for ^TMP("RM") to be set to $J to
+7 ; prevent killing other user's work area.
+8 ;
+9 ;I '$D(^PRC(440.5,"H",DUZ)) W !!,"You are not an authorized Purchase Card User, CONTACT FISCAL!" Q
START IF '$DATA(RMPR)
DO DIV4^RMPRSIT
if $DATA(X)
QUIT
CL KILL ^TMP($JOB,"RMPRPCE")
+1 KILL DIC
SET DIC="664"
SET DIC(0)="AEQM"
SET DIC("W")="D EN2^RMPR4D1"
SET DIC("A")="Select PATIENT: "
+2 SET DIC("S")="I $D(^(4)) I ('$P(^(0),U,8)&'$P(^(0),U,5)),($P(^(0),U,14)=RMPR(""STA""))"
+3 WRITE !!,"You may also make a selection by Purchase Card Transaction"
+4 WRITE !,"(Example, PO number), or Bank Authorization Number (6 digit number).",!
+5 DO ^DIC
SET (DA,RMPRA)=+Y
IF Y=-1
GOTO EXIT
+6 KILL DIC
if $PIECE(^RMPR(664,RMPRA,0),U,8)
GOTO M4
if $PIECE(^(0),U,5)
GOTO M6
+7 LOCK +^RMPR(664,RMPRA,0):1
IF $TEST=0
WRITE !,?5,$CHAR(7),"Someone else is Editing this entry!"
GOTO EXIT
+8 ;get amis grouper number RGRP1
+9 SET RGRP=0
SET RGRP1=""
+10 SET RGRP=$ORDER(^RMPR(664,RMPRA,1,RGRP))
if 'RGRP
GOTO BRK
SET RGRPP=$PIECE($GET(^RMPR(664,RMPRA,1,RGRP,0)),U,13)
IF 'RGRPP
WRITE !!,$CHAR(7),"ERROR** This transaction was not posted to 2319, please contact your IRM..",!!
SET DIR(0)="E"
DO ^DIR
GOTO EXIT
+11 SET RGRP1=$PIECE($GET(^RMPR(660,RGRPP,"AMS")),U,1)
+12 SET (RMPRDFN,DFN)=$PIECE(^RMPR(664,RMPRA,0),U,2)
SET RMPRWO=$PIECE(^(0),U,15)
SET RMPRDA=$PIECE(^(0),U,17)
+13 DO DEM^VADPT
SET RMPRSSNE=VA("PID")
SET RMPRSSN=+VADM(2)
SET RMPRNAM=VADM(1)
KILL VADM
+14 ;set original value before close-out
+15 KILL ^TMP("RM",$JOB),RM(RMPRA),RHCED
SET RMPRF=2
+16 KILL %X,%Y
SET %X="^RMPR(664,RMPRA,"
SET %Y="^TMP("_"""RM"""_",$J,RMPRA,"
DO %XY^%RCR
+17 SET RM(RMPRA,0)=$GET(^RMPR(664,RMPRA,0))
SET RM(RMPRA,2)=$GET(^(2))
SET RM(RMPRA,4)=$GET(^(4))
+18 SET RMPER=$PIECE(RM(RMPRA,2),U,6)
SET RMBAN=$PIECE(RM(RMPRA,4),U,2)
SET RMSHI=$PIECE(RM(RMPRA,0),U,11)
SET RMSHIEN=$PIECE(RM(RMPRA,0),U,12)
+19 if RMSHI=""!(RMSHI+0=0)
SET RMSHI=0
+20 ;added by #62
+21 ;collect all items and previous linkage to suspense.
+22 IF $GET(RMSHIEN)
if '$DATA(^RMPR(660,RMSHIEN,10))
SET RM60LINK(RMSHIEN)=""
+23 DO COL^RMPRPCEL
+24 ;
L ;**** ask for final posting *****************************************
+1 DO ^RMPR4LI
NEW DIR
KILL RFLG
+2 SET DIR("A")="Ready to Reconcile and Close-Out Transaction"
SET DIR("B")="NO"
SET DIR(0)="Y"
+3 SET DIR("?")="You may now Close-out and Post this Transaction. Please answer Yes or No."
+4 DO ^DIR
IF Y["^"!($DATA(DTOUT))
WRITE !,"Transaction NOT Closed-Out!"
if $DATA(^TMP("RM",$JOB))
SET RFLG=1
if $DATA(RFLG)
GOTO POST1
GOTO KTMP
+5 IF Y=1
GOTO POST1
+6 ;***add/edit transaction**********************************************
L1 KILL DIR
SET DIR(0)="FO"
SET DIR("A")="Select ITEM"
+1 SET DIR("?")="^S RFL=1 D ZDSP^RMPR421A"
+2 DO ^DIR
if (Y="^")!(Y="")
GOTO DS
if $DATA(DTOUT)
GOTO L
+3 if $DATA(DIRUT)&($DATA(^RMPR(664,RMPRA,1)))
GOTO L
+4 SET DIC=661
SET DIC(0)="ENMZ"
DO ^DIC
IF +Y'>0
WRITE !,"** No Item selected.."
GOTO DS
+5 if $DATA(DTOUT)!$DATA(DUOUT)
GOTO L
+6 DO PROC
GOTO L1
+7 ;
+8 ;RMPR*3.0*211 changes; called by "DEL" node code on the .01 field of the #664.02 multiple
IC() ;DETERMINE NUMBER OF ITEMS FOR PURCHASING AND CLOSE-OUT
+1 NEW RMPRICS,RMPRIC
+2 SET RMPRICS=0
IF $DATA(RMPRA)
FOR
SET RMPRICS=$ORDER(^RMPR(664,RMPRA,1,RMPRICS))
if RMPRICS'>0
QUIT
SET RMPRIC=$GET(RMPRIC)+1
+3 if RMPRIC'=1
QUIT RMPRIC
IC1 ;DISPLAY TEXT FOR DELETE (@) ATTEMPTS FOR MULTIPLES OF ONLY 1 ITEM
+1 WRITE !!,"You may not delete the single remaining item in the BILLING ITEM"
+2 WRITE !,"sub-file. If you want to change the existing item to a different"
+3 WRITE !,"item, add the new item and then delete the desired item.",!!
+4 SET X="?"
+5 QUIT RMPRIC
+6 ;End of RMPR*3.0*211 changes
+7 ;***process items*******************************************************
PROC NEW NEW
SET HY=+Y
IF $DATA(^RMPR(664,RMPRA,1,"B",+Y))
SET DA=$ORDER(^RMPR(664,RMPRA,1,"B",+Y,0))
GOTO CHK
FILE SET Y=HY
SET NUM=$PIECE(^RMPR(664,RMPRA,1,0),U,3)+1
SET $PIECE(^(0),U,3)=NUM
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
SET ^RMPR(664,RMPRA,1,NUM,0)=+Y
SET DA=NUM
SET ^RMPR(664,RMPRA,1,"B",+Y,NUM)=""
SET NEW=1
ENT KILL DR,DQ
SET DA(1)=RMPRA
SET DIE="^RMPR(664,"_RMPRA_",1,"
+1 ;S DR=$S($D(NEW):"",1:".01;")
+2 IF '$DATA(NEW)
IF ($PIECE(^RMPR(664,RMPRA,1,DA,0),U,7)="")
SET $PIECE(^(0),U,7)=$PIECE(^(0),U,3)
+3 if '$DATA(NEW)
SET RMDACA=$PIECE(^RMPR(664,RMPRA,1,DA,0),U,13)
+4 SET R4DA=DA
+5 SET DR="8;S RMTYPE=$P(^RMPR(664,RMPRA,1,R4DA,0),U,9);9;.01;"
+6 ;RMPR*3.0*182
SET DR=DR_"16R;1;14;17;13;15.4;15;15.6;3R;"
+7 IF $DATA(NEW)
SET DR=DR_"2R~UNIT COST;"
+8 IF '$TEST
SET DR=DR_"6R;"
SET RHCNEW=$PIECE($GET(^RMPR(664,RMPRA,1,R4DA,0)),U,16)
+9 SET DR=DR_"4R~UNIT OF ISSUE;7;11////C"
DO ^DIE
+10 IF $DATA(NEW)
if $GET(DA)
SET ^TMP("RM",$JOB,"N",R4DA)=$GET(^RMPR(664,RMPRA,1,R4DA,0))
+11 IF '$TEST
if '$GET(DA)&(RMDACA)
SET ^TMP("RM",$JOB,"C",RMDACA)=""
IF $GET(DA)
SET ^TMP("RM",$JOB,"E",DA)=$GET(^RMPR(664,RMPRA,1,DA,0))
SET RHCOLD=$PIECE(^RMPR(664,RMPRA,1,DA,0),U,16)
SET RD660=$PIECE(^(0),U,13)
IF RHCNEW'=RHCOLD
Begin DoDot:1
+12 SET RHCED=1
+13 IF $DATA(RD660)&(RD660)
SET DIE="^RMPR(660,"
SET DA=RD660
SET DR="4.5///^S X=$G(RHCOLD)"
DO ^DIE
End DoDot:1
+14 IF $DATA(R4DA)
IF $PIECE($GET(^RMPR(664,RMPRA,1,R4DA,0)),U,10)=4
SET DA=R4DA
SET DR=10
DO ^DIE
+15 ;check for Type of Transaction and update the cpt modifier.
+16 IF $DATA(R4DA)
IF $DATA(RMTYPE)
SET RDATA=RMTYPE_"^"_RMPRA_"^"_R4DA
DO CHKCPT^RMPR4UTL(RDATA)
+17 if $DATA(DTOUT)
QUIT
KILL NUM,R4DA,DA,Y,DR,RD660,RHCOLD,RHCNEW,DIE,RDATA,RMTYPE
QUIT
CHK ;ADD DUPLICATE LINE ITEM
+1 KILL DIR,Y
SET DIR(0)="S^Y:YES;N:NO"
SET DIR("A")="DO YOU WANT TO ADD A DUPLICATE ITEM?"
SET DIR("B")="NO"
DO ^DIR
if $DATA(DIRUT)!($DATA(DTOUT))
QUIT
IF (X["Y")!(X["y")
GOTO FILE
+2 SET RD=0
FOR RDA=0:0
SET RDA=$ORDER(^RMPR(664,RMPRA,1,"B",HY,RDA))
if RDA'>0
QUIT
SET RD=RD+1
LKP IF RD>1
Begin DoDot:1
+1 FOR RDA=0:0
SET RDA=$ORDER(^RMPR(664,RMPRA,1,"B",HY,RDA))
if RDA'>0
QUIT
SET RD(RDA)=^RMPR(664,RMPRA,1,RDA,0)
WRITE !?5,RDA,?10,$PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(RD(RDA),U),0),U),0),U,2)," $",$SELECT($PIECE(RD(RDA),U,7)'="":$PIECE(RD(RDA),U,7),1:$PIECE(RD(RDA),U,3))
+2 KILL DIR,Y
SET DIR(0)="N"
DO ^DIR
IF +Y
SET DA=+Y
End DoDot:1
if $DATA(DIRUT)!$DATA(DTOUT)
QUIT
IF '$DATA(RD(+Y))
WRITE $CHAR(7)
GOTO LKP
+3 GOTO ENT
+4 ;
DS ;**** update shipping cost, % discount and bank authorization ********
+1 SET (RMPERF,RMBANF,RMSHIF)=0
+2 IF $PIECE(^RMPR(664,RMPRA,0),U,11)=""
IF $PIECE(^(0),U,10)
SET $PIECE(^(0),U,11)=$PIECE(RM(RMPRA,0),U,10)
+3 SET DA=RMPRA
SET DIE="^RMPR(664,"
SET DR="12;17;26"
DO ^DIE
+4 if +$PIECE(^RMPR(664,RMPRA,0),U,11)=0
SET $PIECE(^(0),U,11)=0
+5 IF RMPER'=$PIECE(^RMPR(664,RMPRA,2),U,6)
SET RMPERF=1
+6 IF RMBAN'=$PIECE(^RMPR(664,RMPRA,4),U,2)
SET RMBANF=1
+7 IF RMSHI'=$PIECE(^RMPR(664,RMPRA,0),U,11)!($PIECE(^(0),U,11)=0&$PIECE(^(0),U,12))
SET RMSHIF=1
CHK1 ;delete imcomplete items
+1 SET DIK="^RMPR(664,"_RMPRA_",1,"
SET DA(1)=RMPRA
FOR I=0:0
SET I=$ORDER(^RMPR(664,RMPRA,1,I))
if I'>0
QUIT
SET RMPRI=$GET(^(I,0))
IF $PIECE(RMPRI,U,3)=""!($PIECE(RMPRI,U,4)="")!($PIECE(RMPRI,U,5)="")
SET DA=I
DO ^DIK
+2 ;go back to select ITEM
GOTO L
+3 ;*************************************************************
POST1 ;SET AMOUNT FOR IFCAP AMENDMENT.
+1 SET (R1,RMPR("AMT"),AMT,DCT,RMPRTO)=0
+2 IF $DATA(^RMPR(664,RMPRA,2))
IF $PIECE(^(2),U,6)
SET DCT=$PIECE(^(2),U,6)
SET DCT=DCT/100
+3 FOR RI=0:0
SET RI=$ORDER(^RMPR(664,RMPRA,1,RI))
if RI'>0
QUIT
Begin DoDot:1
+4 NEW RMACT
+5 SET RMX=$GET(^RMPR(664,RMPRA,1,RI,0))
SET RMACT=$PIECE(RMX,U,7)
SET RMQTY=$PIECE(RMX,U,4)
+6 IF DCT
SET RMTOT=$SELECT(RMACT=0!(RMACT>0):RMACT-$JUSTIFY(RMACT*DCT,0,2)*RMQTY,1:$PIECE(RMX,U,3)-$JUSTIFY($PIECE(RMX,U,3)*DCT,0,2)*RMQTY)
+7 IF 'DCT
SET RMTOT=$SELECT(RMACT=0!(RMACT>0):RMACT*RMQTY,1:$PIECE(RMX,U,3)*RMQTY)
+8 SET RMPR("AMT")=RMPR("AMT")+RMTOT
SET RMPRTO=RMPR("AMT")
End DoDot:1
+9 SET RMPRSH=$SELECT($PIECE(^RMPR(664,RMPRA,0),U,11)=0:0,$PIECE(^RMPR(664,RMPRA,0),U,11):$PIECE(^(0),U,11),$PIECE(^RMPR(664,RMPRA,0),U,10):$PIECE(^(0),U,10),1:"")
+10 DO CHECK^RMPRCT
IF '$DATA(RMPRTO)
WRITE !,"***** NOT CLOSED-OUT !!!!"
GOTO KTMP
+11 ;**************************************************************
+12 ;check 4;3,2;8&2;9&4;6 call PRCH7C if needed
+13 ;if total amount has not changed, then don't need to call ammend
+14 ;if it is an early record with no ifcap order then don't call ammend
+15 ;set the reprint flag
+16 IF $FNUMBER($PIECE(^RMPR(664,RMPRA,4),U,3),"P",2)'=$FNUMBER(RMPRTO+RMPRSH,"P",2)&($PIECE(^(2),U,9)="")!($PIECE(^(2),U,9)'="")&($FNUMBER($PIECE(^(2),U,9),"P",2)'=$FNUMBER(RMPRTO+RMPRSH,"P",2))
Begin DoDot:1
+17 ;call IFCAP AMMEND
+18 SET RMPR442=$PIECE(^RMPR(664,RMPRA,4),U,6)
IF RMPR442=""
QUIT
+19 DO AMEND^PRCH7C(RMPR442,RMPRTO+RMPRSH)
+20 IF X=1
SET $PIECE(^RMPR(664,RMPRA,2),U,8)=DUZ
SET $PIECE(^RMPR(664,RMPRA,2),U,9)=RMPRTO+RMPRSH
SET $PIECE(^RMPR(664,RMPRA,2),U,10)=1
+21 IF X'=1
SET $PIECE(^RMPR(664,RMPRA,2),U,10)=""
End DoDot:1
IF (X=0)&'$DATA(^TMP("RM",$JOB))
WRITE !!,"**** NOT CLOSED-OUT!! ****"
GOTO KTMP
+22 ;do posting to 660
+23 IF $DATA(^TMP("RM",$JOB))!$GET(RMSHIF)!$GET(RMPERF)!$GET(RMBANF)
DO POST2^RMPR4M
+24 IF $DATA(RMPRWO)
IF $DATA(^RMPR(664.2,+RMPRWO,0))
SET $PIECE(^("AM"),U,2)=1
SET $PIECE(^RMPR(664.2,+RMPRWO,0),U,7)=$PIECE(^(0),U,7)+RMPRSH
DO DA0^RMPR29M(RMPRDA,RMPRA)
DO POST^RMPR29U
+25 if $DATA(RFLG)
GOTO EXIT
+26 ;go to exit in above line if not close-out.
+27 ;close-out remarks
+28 WRITE !
SET DIE="^RMPR(664,"
SET DA=RMPRA
SET DR="8.1"
DO ^DIE
SET RMPRCC=$PIECE($GET(^RMPR(664,RMPRA,2)),U,3)
+29 FOR
SET R1=$ORDER(^RMPR(664,RMPRA,1,R1))
if R1'>0
QUIT
IF $DATA(^(R1,0))
Begin DoDot:1
+30 NEW RM660
+31 SET RM660=$PIECE($GET(^(0)),U,13)
IF RM660
IF $PIECE($GET(^RMPR(660,RM660,0)),U,18)'[RMPRCC
SET $PIECE(^(0),U,18)=$PIECE(^(0),U,18)_" "_RMPRCC
End DoDot:1
+32 ;
EX ;***reindex record in 664 here
+1 LOCK -^RMPR(664,RMPRA,0)
+2 ;IFCAP final charge payment
+3 ;don't call recon if it is an early record, no ifcap order.
SET RMPR442=$PIECE(^RMPR(664,RMPRA,4),U,6)
+4 ;RMPR*3.0*198 when file #442 does not exist a reconcile cannot occur
IF $GET(RMPR442)
IF '$DATA(^PRC(442,RMPR442,0))
DO M442
QUIT
+5 if RMPR442'=""
DO RECON^PRCH7C(RMPR442,DUZ)
+6 IF (X=0)&(RMPR442'="")
WRITE !!,"**** TRANSACTION NOT CLOSED-OUT!! ****"
GOTO EX1
+7 SET $PIECE(^RMPR(664,RMPRA,4),U,4)=RMPRTO+RMPRSH
+8 ;set close out date
+9 DO NOW^%DTC
SET $PIECE(^RMPR(664,RMPRA,0),U,8)=%
+10 ;set closed by
+11 SET $PIECE(^RMPR(664,RMPRA,2),U,7)=DUZ
SET DA=$PIECE(^RMPR(664,RMPRA,0),U,12)
+12 IF DA'=""
SET $PIECE(^RMPR(660,DA,0),U,12)=%
SET DIK="^RMPR(660,"
DO IX1^DIK
+13 SET RMPR660=0
SET DA=""
SET DIK="^RMPR(660,"
+14 FOR
SET RMPR660=$ORDER(^RMPR(664,RMPRA,1,RMPR660))
if RMPR660'>0
QUIT
Begin DoDot:1
+15 ;get pointer from item mult
+16 SET DA=$PIECE(^RMPR(664,RMPRA,1,RMPR660,0),U,13)
+17 ;set delivery date
+18 IF DA'=""
SET $PIECE(^RMPR(660,DA,0),U,12)=DT
DO IX1^DIK
+19 ;Patch #78 - Get IFCAP Transaction Date and prompt for Shipment Date
+20 IF DA'=""
SET SKPSHDT=1
DO ^RMPR4E23
KILL SKPSHDT
End DoDot:1
EX1 ;
+1 IF $DATA(RM60LINK)
Begin DoDot:1
+2 FOR I=0:0
SET I=$ORDER(RM60LINK(I))
if I'>0
QUIT
Begin DoDot:2
+3 IF '$DATA(^RMPR(660,I,0))
KILL RM60LINK(I)
End DoDot:2
End DoDot:1
+4 ;added by #62
+5 if $DATA(RM68FG)=1
DO AUTO^RMPRPCEL
if $DATA(RM68FG)>1
DO MAN^RMPRPCEL
+6 ;
+7 DO EXIT
+8 WRITE !!,"Enter Next Transaction to Close-out, or <RETURN> to continue."
+9 GOTO CL
+10 ;
EXIT ;KILL VARIABLES AND EXIT ROUTINE
+1 if $DATA(RMPRA)
LOCK -^RMPR(664,RMPRA,0)
+2 ;RMPR*3.0*182
KILL ^TMP($JOB),^TMP("RM",$JOB)
+3 KILL RGRP,RGRP1,RGRPP,RMBAN,RMBANF
+4 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+5 QUIT
+6 ;
KTMP SET DIK="^RMPR(664,"_RMPRA_",1,"
SET DA(1)=RMPRA
FOR I=0:0
SET I=$ORDER(^TMP("RM",$JOB,"N",I))
if I'>0
QUIT
SET DA=I
DO ^DIK
+1 SET %X="^TMP("_"""RM"""_",$J,RMPRA,"
SET %Y="^RMPR(664,RMPRA,"
DO %XY^%RCR
GOTO EX1
BRK WRITE !,$CHAR(7),"INCOMPLETE RECORD..file 664..entry..",RMPRA,"...PLEASE CONTACT YOUR IRM or CANCEL THIS ENTRY!!!"
GOTO EX1
UNK WRITE !,$CHAR(7),"UNKNOWN 2319 RECORD TO UPDATE, 2319 NOT UPDATED!"
GOTO EXIT
M4 WRITE !,$CHAR(7),"This Transaction has already been CLOSED!"
GOTO EXIT
M6 WRITE !,$CHAR(7),"This Transaction has been CANCELED!"
GOTO EXIT
M442 WRITE !,$CHAR(7),"This order cannot be Reconciled. The Purchase Order no longer exists."
GOTO EXIT
