- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4E21.m
r613 r623 1 RMPR4E21 ;PHX/HNC - CLOSE OUT PURCHASE CARD TRANSACTION ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,12,26,28,30,34,41,45,62,111,78,114,118,133,137**;Feb 09, 1996;Build 5 3 ;TH Patch #78 - 08/04/03 - Add shipment date. Call routine ^RMPR4E23 4 ;RVD patch #62 - PCE processing and link to suspense 5 ; 6 ;I '$D(^PRC(440.5,"H",DUZ)) W !!,"You are not an authorized Purchase Card User, CONTACT FISCAL!" Q 7 START I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X) 8 CL K ^TMP($J,"RMPRPCE") 9 K DIC S DIC="664",DIC(0)="AEQM",DIC("W")="D EN2^RMPR4D1",DIC("A")="Select PATIENT: " 10 S DIC("S")="I $D(^(4)) I ('$P(^(0),U,8)&'$P(^(0),U,5)),($P(^(0),U,14)=RMPR(""STA""))" 11 W !!,"You may also make a selection by Purchase Card Transaction" 12 W !,"(Example, PO number), or Bank Authorization Number (6 digit number).",! 13 D ^DIC S (DA,RMPRA)=+Y I Y=-1 G EXIT 14 K DIC G:$P(^RMPR(664,RMPRA,0),U,8) M4 G:$P(^(0),U,5) M6 15 L +^RMPR(664,RMPRA,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT 16 ;get amis grouper number RGRP1 17 S RGRP=0,RGRP1="" 18 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 19 S RGRP1=$P($G(^RMPR(660,RGRPP,"AMS")),U,1) 20 S (RMPRDFN,DFN)=$P(^RMPR(664,RMPRA,0),U,2),RMPRWO=$P(^(0),U,15),RMPRDA=$P(^(0),U,17) 21 D DEM^VADPT S RMPRSSNE=VA("PID"),RMPRSSN=+VADM(2),RMPRNAM=VADM(1) K VADM 22 ;set original value before close-out 23 K ^TMP("RM",$J),RM(RMPRA),RHCED S RMPRF=2 24 K %X,%Y S %X="^RMPR(664,RMPRA,",%Y="^TMP("_"""RM"""_",$J,RMPRA," D %XY^%RCR 25 S RM(RMPRA,0)=$G(^RMPR(664,RMPRA,0)),RM(RMPRA,2)=$G(^(2)),RM(RMPRA,4)=$G(^(4)) 26 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) 27 S:RMSHI=""!(RMSHI+0=0) RMSHI=0 28 ;added by #62 29 ;collect all items and previous linkage to suspense. 30 I $G(RMSHIEN) S:'$D(^RMPR(660,RMSHIEN,10)) RM60LINK(RMSHIEN)="" 31 D COL^RMPRPCEL 32 ; 33 L ;**** ask for final posting ***************************************** 34 D ^RMPR4LI N DIR K RFLG 35 S DIR("A")="Ready to Reconcile and Close-Out Transaction",DIR("B")="NO",DIR(0)="Y" 36 S DIR("?")="You may now Close-out and Post this Transaction. Please answer Yes or No." 37 D ^DIR I Y["^"!($D(DTOUT)) W !,"Transaction NOT Closed-Out!" S:$D(^TMP("RM",$J)) RFLG=1 G:$D(RFLG) POST1 G KTMP 38 I Y=1 G POST1 39 ;***add/edit transaction********************************************** 40 L1 K DIR S DIR(0)="FO",DIR("A")="Select ITEM" 41 S DIR("?")="^S RFL=1 D ZDSP^RMPR421A" 42 D ^DIR G:(Y="^")!(Y="") DS G:$D(DTOUT) L 43 G:$D(DIRUT)&($D(^RMPR(664,RMPRA,1))) L 44 S DIC=661,DIC(0)="ENMZ" D ^DIC I +Y'>0 W !,"** No Item selected.." G DS 45 G:$D(DTOUT)!$D(DUOUT) L 46 D PROC G L1 47 ;***process items******************************************************* 48 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 49 FILE S Y=HY,NUM=$P(^RMPR(664,RMPRA,1,0),U,4)+1,$P(^(0),U,4)=NUM,$P(^(0),U,3)=$P(^(0),U,3)+1,^RMPR(664,RMPRA,1,NUM,0)=+Y,DA=NUM,^RMPR(664,RMPRA,1,"B",+Y,NUM)="" S NEW=1 50 ENT K DR,DQ S DA(1)=RMPRA,DIE="^RMPR(664,"_RMPRA_",1," 51 ;S DR=$S($D(NEW):"",1:".01;") 52 I '$D(NEW),($P(^RMPR(664,RMPRA,1,DA,0),U,7)="") S $P(^(0),U,7)=$P(^(0),U,3) 53 S:'$D(NEW) RMDACA=$P(^RMPR(664,RMPRA,1,DA,0),U,13) 54 S R4DA=DA 55 S DR="8;S RMTYPE=$P(^RMPR(664,RMPRA,1,R4DA,0),U,9);9;.01;" 56 S DR=DR_"16R;1;14;17;15;3R;" 57 I $D(NEW) S DR=DR_"2R~UNIT COST;" 58 E S DR=DR_"6R;",RHCNEW=$P($G(^RMPR(664,RMPRA,1,R4DA,0)),U,16) 59 S DR=DR_"4R~UNIT OF ISSUE;7;11////C" D ^DIE 60 I $D(NEW) S:$G(DA) ^TMP("RM",$J,"N",R4DA)=$G(^RMPR(664,RMPRA,1,R4DA,0)) 61 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 62 .S RHCED=1 63 .I $D(RD660)&(RD660) S DIE="^RMPR(660,",DA=RD660,DR="4.5///^S X=$G(RHCOLD)" D ^DIE 64 I $D(R4DA),$P($G(^RMPR(664,RMPRA,1,R4DA,0)),U,10)=4 S DA=R4DA,DR=10 D ^DIE 65 ;check for Type of Transaction and update the cpt modifier. 66 I $D(R4DA),$D(RMTYPE) S RDATA=RMTYPE_"^"_RMPRA_"^"_R4DA D CHKCPT^RMPR4UTL(RDATA) 67 Q:$D(DTOUT) K NUM,R4DA,DA,Y,DR,RD660,RHCOLD,RHCNEW,DIE,RDATA,RMTYPE Q 68 CHK ;ADD DUPLICATE LINE ITEM 69 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 70 S RD=0 F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD=RD+1 71 LKP I RD>1 D Q:$D(DIRUT)!$D(DTOUT) I '$D(RD(+Y)) W $C(7) G LKP 72 .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)) 73 .K DIR,Y S DIR(0)="N" D ^DIR I +Y S DA=+Y 74 G ENT 75 ; 76 DS ;**** update shipping cost, % discount and bank authorization ******** 77 S (RMPERF,RMBANF,RMSHIF)=0 78 I $P(^RMPR(664,RMPRA,0),U,11)="",$P(^(0),U,10) S $P(^(0),U,11)=$P(RM(RMPRA,0),U,10) 79 S DA=RMPRA,DIE="^RMPR(664,",DR="12;17;26" D ^DIE 80 S:+$P(^RMPR(664,RMPRA,0),U,11)=0 $P(^(0),U,11)=0 81 I RMPER'=$P(^RMPR(664,RMPRA,2),U,6) S RMPERF=1 82 I RMBAN'=$P(^RMPR(664,RMPRA,4),U,2) S RMBANF=1 83 I RMSHI'=$P(^RMPR(664,RMPRA,0),U,11)!($P(^(0),U,11)=0&$P(^(0),U,12)) S RMSHIF=1 84 CHK1 ;delete imcomplete items 85 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 86 G L ;go back to select ITEM 87 ;************************************************************* 88 POST1 ;SET AMOUNT FOR IFCAP AMENDMENT. 89 S (R1,RMPR("AMT"),AMT,DCT,RMPRTO)=0 90 I $D(^RMPR(664,RMPRA,2)),$P(^(2),U,6) S DCT=$P(^(2),U,6),DCT=DCT/100 91 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 D 92 .N RMACT 93 .S RMX=$G(^RMPR(664,RMPRA,1,RI,0)),RMACT=$P(RMX,U,7),RMQTY=$P(RMX,U,4) 94 .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) 95 .I 'DCT S RMTOT=$S(RMACT=0!(RMACT>0):RMACT*RMQTY,1:$P(RMX,U,3)*RMQTY) 96 .S RMPR("AMT")=RMPR("AMT")+RMTOT,RMPRTO=RMPR("AMT") 97 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:"") 98 D CHECK^RMPRCT I '$D(RMPRTO) W !,"***** NOT CLOSED-OUT !!!!" G KTMP 99 ;************************************************************** 100 ;check 4;3,2;8&2;9&4;6 call PRCH7C if needed 101 ;if total amount has not changed, then don't need to call ammend 102 ;if it is an early record with no ifcap order then don't call ammend 103 ;set the reprint flag 104 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 105 .;call IFCAP AMMEND 106 .S RMPR442=$P(^RMPR(664,RMPRA,4),U,6) I RMPR442="" Q 107 .D AMEND^PRCH7C(RMPR442,RMPRTO+RMPRSH) 108 .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 109 .I X'=1 S $P(^RMPR(664,RMPRA,2),U,10)="" 110 ;do posting to 660 111 I $D(^TMP("RM",$J))!$G(RMSHIF)!$G(RMPERF)!$G(RMBANF) D POST2^RMPR4M 112 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 113 G:$D(RFLG) EXIT 114 ;go to exit in above line if not close-out. 115 ;close-out remarks 116 W ! S DIE="^RMPR(664,",DA=RMPRA,DR="8.1" D ^DIE S RMPRCC=$P($G(^RMPR(664,RMPRA,2)),U,3) 117 F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 I $D(^(R1,0)) D 118 .N RM660 119 .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 120 ; 121 EX ;***reindex record in 664 here 122 L -^RMPR(664,RMPRA,0) 123 ;IFCAP final charge payment 124 S RMPR442=$P(^RMPR(664,RMPRA,4),U,6) ;don't call recon if it is an early record, no ifcap order. 125 D:RMPR442'="" RECON^PRCH7C(RMPR442,DUZ) 126 I (X=0)&(RMPR442'="") W !!,"**** TRANSACTION NOT CLOSED-OUT!! ****" G EX1 127 S $P(^RMPR(664,RMPRA,4),U,4)=RMPRTO+RMPRSH 128 ;set close out date 129 D NOW^%DTC S $P(^RMPR(664,RMPRA,0),U,8)=% 130 ;set closed by 131 S $P(^RMPR(664,RMPRA,2),U,7)=DUZ,DA=$P(^RMPR(664,RMPRA,0),U,12) 132 I DA'="" S $P(^RMPR(660,DA,0),U,12)=%,DIK="^RMPR(660," D IX1^DIK 133 S RMPR660=0,DA="",DIK="^RMPR(660," 134 F S RMPR660=$O(^RMPR(664,RMPRA,1,RMPR660)) Q:RMPR660'>0 D 135 .;get pointer from item mult 136 .S DA=$P(^RMPR(664,RMPRA,1,RMPR660,0),U,13) 137 .;set delivery date 138 .I DA'="" S $P(^RMPR(660,DA,0),U,12)=DT D IX1^DIK 139 .;Patch #78 - Get IFCAP Transaction Date and prompt for Shipment Date 140 .I DA'="" S SKPSHDT=1 D ^RMPR4E23 K SKPSHDT 141 EX1 ; 142 I $D(RM60LINK) D 143 . F I=0:0 S I=$O(RM60LINK(I)) Q:I'>0 D 144 .. I '$D(^RMPR(660,I,0)) K RM60LINK(I) 145 ;added by #62 146 D:$D(RM68FG)=1 AUTO^RMPRPCEL D:$D(RM68FG)>1 MAN^RMPRPCEL 147 ; 148 D EXIT 149 W !!,"Enter Next Transaction to Close-out, or <RETURN> to continue." 150 G CL 151 ; 152 EXIT ;KILL VARIABLES AND EXIT ROUTINE 153 L:$D(RMPRA) -^RMPR(664,RMPRA,0) 154 K ^TMP($J),^TMP("RM") 155 K RGRP,RGRP1,RGRPP,RMBAN,RMBANF 156 N RMPR,RMPRSITE D KILL^XUSCLEAN 157 Q 158 ; 159 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 160 S %X="^TMP("_"""RM"""_",$J,RMPRA,",%Y="^RMPR(664,RMPRA," D %XY^%RCR G EX1 161 BRK W !,$C(7),"INCOMPLETE RECORD..file 664..entry..",RMPRA,"...PLEASE CONTACT YOUR IRM or CANCEL THIS ENTRY!!!" G EX1 162 UNK W !,$C(7),"UNKNOWN 2319 RECORD TO UPDATE, 2319 NOT UPDATED!" G EXIT 163 M4 W !,$C(7),"This Transaction has already been CLOSED!" G EXIT 164 M6 W !,$C(7),"This Transaction has been CANCELED!" G EXIT 1 RMPR4E21 ;PHX/HNC - CLOSE OUT PURCHASE CARD TRANSACTION ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,12,26,28,30,34,41,45,62,111,78,114,118,133**;Feb 09, 1996;Build 2 3 ;TH Patch #78 - 08/04/03 - Add shipment date. Call routine ^RMPR4E23 4 ;RVD patch #62 - PCE processing and link to suspense 5 ; 6 ;I '$D(^PRC(440.5,"H",DUZ)) W !!,"You are not an authorized Purchase Card User, CONTACT FISCAL!" Q 7 START I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X) 8 CL K ^TMP($J,"RMPRPCE") 9 K DIC S DIC="664",DIC(0)="AEQM",DIC("W")="D EN2^RMPR4D1",DIC("A")="Select PATIENT: " 10 S DIC("S")="I $D(^(4)) I ('$P(^(0),U,8)&'$P(^(0),U,5)),($P(^(0),U,14)=RMPR(""STA""))" 11 W !!,"You may also make a selection by Purchase Card Transaction" 12 W !,"(Example, PO number), or Bank Authorization Number (6 digit number).",! 13 D ^DIC S (DA,RMPRA)=+Y I Y=-1 G EXIT 14 K DIC G:$P(^RMPR(664,RMPRA,0),U,8) M4 G:$P(^(0),U,5) M6 15 L +^RMPR(664,RMPRA,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT 16 ;get amis grouper number RGRP1 17 S RGRP=0,RGRP1="" 18 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 19 S RGRP1=$P($G(^RMPR(660,RGRPP,"AMS")),U,1) 20 S (RMPRDFN,DFN)=$P(^RMPR(664,RMPRA,0),U,2),RMPRWO=$P(^(0),U,15),RMPRDA=$P(^(0),U,17) 21 D DEM^VADPT S RMPRSSNE=VA("PID"),RMPRSSN=+VADM(2),RMPRNAM=VADM(1) K VADM 22 ;set original value before close-out 23 K ^TMP("RM",$J),RM(RMPRA),RHCED S RMPRF=2 24 K %X,%Y S %X="^RMPR(664,RMPRA,",%Y="^TMP("_"""RM"""_",$J,RMPRA," D %XY^%RCR 25 S RM(RMPRA,0)=$G(^RMPR(664,RMPRA,0)),RM(RMPRA,2)=$G(^(2)),RM(RMPRA,4)=$G(^(4)) 26 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) 27 ;added by #62 28 ;collect all items and previous linkage to suspense. 29 I $G(RMSHIEN) S:'$D(^RMPR(660,RMSHIEN,10)) RM60LINK(RMSHIEN)="" 30 D COL^RMPRPCEL 31 ; 32 L ;**** ask for final posting ***************************************** 33 D ^RMPR4LI N DIR K RFLG 34 S DIR("A")="Ready to Reconcile and Close-Out Transaction",DIR("B")="NO",DIR(0)="Y" 35 S DIR("?")="You may now Close-out and Post this Transaction. Please answer Yes or No." 36 D ^DIR I Y["^"!($D(DTOUT)) W !,"Transaction NOT Closed-Out!" S:$D(^TMP("RM",$J)) RFLG=1 G:$D(RFLG) POST1 G KTMP 37 I Y=1 G POST1 38 ;***add/edit transaction********************************************** 39 L1 K DIR S DIR(0)="FO",DIR("A")="Select ITEM" 40 S DIR("?")="^S RFL=1 D ZDSP^RMPR421A" 41 D ^DIR G:(Y="^")!(Y="") DS G:$D(DTOUT) L 42 G:$D(DIRUT)&($D(^RMPR(664,RMPRA,1))) L 43 S DIC=661,DIC(0)="ENMZ" D ^DIC I +Y'>0 W !,"** No Item selected.." G DS 44 G:$D(DTOUT)!$D(DUOUT) L 45 D PROC G L1 46 ;***process items******************************************************* 47 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 48 FILE S Y=HY,NUM=$P(^RMPR(664,RMPRA,1,0),U,4)+1,$P(^(0),U,4)=NUM,$P(^(0),U,3)=$P(^(0),U,3)+1,^RMPR(664,RMPRA,1,NUM,0)=+Y,DA=NUM,^RMPR(664,RMPRA,1,"B",+Y,NUM)="" S NEW=1 49 ENT K DR,DQ S DA(1)=RMPRA,DIE="^RMPR(664,"_RMPRA_",1," 50 ;S DR=$S($D(NEW):"",1:".01;") 51 I '$D(NEW),($P(^RMPR(664,RMPRA,1,DA,0),U,7)="") S $P(^(0),U,7)=$P(^(0),U,3) 52 S:'$D(NEW) RMDACA=$P(^RMPR(664,RMPRA,1,DA,0),U,13) 53 S R4DA=DA 54 S DR="8;S RMTYPE=$P(^RMPR(664,RMPRA,1,R4DA,0),U,9);9;.01;" 55 S DR=DR_"16R;1;14;17;15;3R;" 56 I $D(NEW) S DR=DR_"2R~UNIT COST;" 57 E S DR=DR_"6R;",RHCNEW=$P($G(^RMPR(664,RMPRA,1,R4DA,0)),U,16) 58 S DR=DR_"4R~UNIT OF ISSUE;7;11////C" D ^DIE 59 I $D(NEW) S:$G(DA) ^TMP("RM",$J,"N",R4DA)=$G(^RMPR(664,RMPRA,1,R4DA,0)) 60 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 61 .S RHCED=1 62 .I $D(RD660)&(RD660) S DIE="^RMPR(660,",DA=RD660,DR="4.5///^S X=$G(RHCOLD)" D ^DIE 63 I $D(R4DA),$P($G(^RMPR(664,RMPRA,1,R4DA,0)),U,10)=4 S DA=R4DA,DR=10 D ^DIE 64 ;check for Type of Transaction and update the cpt modifier. 65 I $D(R4DA),$D(RMTYPE) S RDATA=RMTYPE_"^"_RMPRA_"^"_R4DA D CHKCPT^RMPR4UTL(RDATA) 66 Q:$D(DTOUT) K NUM,R4DA,DA,Y,DR,RD660,RHCOLD,RHCNEW,DIE,RDATA,RMTYPE Q 67 CHK ;ADD DUPLICATE LINE ITEM 68 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 69 S RD=0 F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD=RD+1 70 LKP I RD>1 D Q:$D(DIRUT)!$D(DTOUT) I '$D(RD(+Y)) W $C(7) G LKP 71 .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)) 72 .K DIR,Y S DIR(0)="N" D ^DIR I +Y S DA=+Y 73 G ENT 74 ; 75 DS ;**** update shipping cost, % discount and bank authorization ******** 76 S (RMPERF,RMBANF,RMSHIF)=0 77 I $P(^RMPR(664,RMPRA,0),U,11)="",$P(^(0),U,10) S $P(^(0),U,11)=$P(RM(RMPRA,0),U,10) 78 S DA=RMPRA,DIE="^RMPR(664,",DR="12;17;26" D ^DIE 79 I RMPER'=$P(^RMPR(664,RMPRA,2),U,6) S RMPERF=1 80 I RMBAN'=$P(^RMPR(664,RMPRA,4),U,2) S RMBANF=1 81 I RMSHI'=$P(^RMPR(664,RMPRA,0),U,11) S RMSHIF=1 82 S:$P(^RMPR(664,RMPRA,0),U,11)="" $P(^(0),U,11)=0 83 CHK1 ;delete imcomplete items 84 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 85 G L ;go back to select ITEM 86 ;************************************************************* 87 POST1 ;SET AMOUNT FOR IFCAP AMENDMENT. 88 S (R1,RMPR("AMT"),AMT,DCT,RMPRTO)=0 89 I $D(^RMPR(664,RMPRA,2)),$P(^(2),U,6) S DCT=$P(^(2),U,6),DCT=DCT/100 90 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 D 91 .N RMACT 92 .S RMX=$G(^RMPR(664,RMPRA,1,RI,0)),RMACT=$P(RMX,U,7),RMQTY=$P(RMX,U,4) 93 .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) 94 .I 'DCT S RMTOT=$S(RMACT=0!(RMACT>0):RMACT*RMQTY,1:$P(RMX,U,3)*RMQTY) 95 .S RMPR("AMT")=RMPR("AMT")+RMTOT,RMPRTO=RMPR("AMT") 96 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:"") 97 D CHECK^RMPRCT I '$D(RMPRTO) W !,"***** NOT CLOSED-OUT !!!!" G KTMP 98 ;************************************************************** 99 ;check 4;3,2;8&2;9&4;6 call PRCH7C if needed 100 ;if total amount has not changed, then don't need to call ammend 101 ;if it is an early record with no ifcap order then don't call ammend 102 ;set the reprint flag 103 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 104 .;call IFCAP AMMEND 105 .S RMPR442=$P(^RMPR(664,RMPRA,4),U,6) I RMPR442="" Q 106 .D AMEND^PRCH7C(RMPR442,RMPRTO+RMPRSH) 107 .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 108 .I X'=1 S $P(^RMPR(664,RMPRA,2),U,10)="" 109 ;do posting to 660 110 I $D(^TMP("RM",$J))!$G(RMSHIF)!$G(RMPERF)!$G(RMBANF) D POST2^RMPR4M 111 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 112 G:$D(RFLG) EXIT 113 ;go to exit in above line if not close-out. 114 ;close-out remarks 115 W ! S DIE="^RMPR(664,",DA=RMPRA,DR="8.1" D ^DIE S RMPRCC=$P($G(^RMPR(664,RMPRA,2)),U,3) 116 F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 I $D(^(R1,0)) D 117 .N RM660 118 .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 119 ; 120 EX ;***reindex record in 664 here 121 L -^RMPR(664,RMPRA,0) 122 ;IFCAP final charge payment 123 S RMPR442=$P(^RMPR(664,RMPRA,4),U,6) ;don't call recon if it is an early record, no ifcap order. 124 D:RMPR442'="" RECON^PRCH7C(RMPR442,DUZ) 125 I (X=0)&(RMPR442'="") W !!,"**** TRANSACTION NOT CLOSED-OUT!! ****" G EX1 126 S $P(^RMPR(664,RMPRA,4),U,4)=RMPRTO+RMPRSH 127 ;set close out date 128 D NOW^%DTC S $P(^RMPR(664,RMPRA,0),U,8)=% 129 ;set closed by 130 S $P(^RMPR(664,RMPRA,2),U,7)=DUZ,DA=$P(^RMPR(664,RMPRA,0),U,12) 131 I DA'="" S $P(^RMPR(660,DA,0),U,12)=%,DIK="^RMPR(660," D IX1^DIK 132 S RMPR660=0,DA="",DIK="^RMPR(660," 133 F S RMPR660=$O(^RMPR(664,RMPRA,1,RMPR660)) Q:RMPR660'>0 D 134 .;get pointer from item mult 135 .S DA=$P(^RMPR(664,RMPRA,1,RMPR660,0),U,13) 136 .;set delivery date 137 .I DA'="" S $P(^RMPR(660,DA,0),U,12)=DT D IX1^DIK 138 .;Patch #78 - Get IFCAP Transaction Date and prompt for Shipment Date 139 .I DA'="" S SKPSHDT=1 D ^RMPR4E23 K SKPSHDT 140 EX1 ; 141 ;added by #62 142 D:$D(RM68FG)=1 AUTO^RMPRPCEL D:$D(RM68FG)>1 MAN^RMPRPCEL 143 ; 144 D EXIT 145 W !!,"Enter Next Transaction to Close-out, or <RETURN> to continue." 146 G CL 147 ; 148 EXIT ;KILL VARIABLES AND EXIT ROUTINE 149 L:$D(RMPRA) -^RMPR(664,RMPRA,0) 150 K ^TMP($J),^TMP("RM") 151 K RGRP,RGRP1,RGRPP,RMBAN,RMBANF 152 N RMPR,RMPRSITE D KILL^XUSCLEAN 153 Q 154 ; 155 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 156 S %X="^TMP("_"""RM"""_",$J,RMPRA,",%Y="^RMPR(664,RMPRA," D %XY^%RCR G EX1 157 BRK W !,$C(7),"INCOMPLETE RECORD..file 664..entry..",RMPRA,"...PLEASE CONTACT YOUR IRM or CANCEL THIS ENTRY!!!" G EX1 158 UNK W !,$C(7),"UNKNOWN 2319 RECORD TO UPDATE, 2319 NOT UPDATED!" G EXIT 159 M4 W !,$C(7),"This Transaction has already been CLOSED!" G EXIT 160 M6 W !,$C(7),"This Transaction has been CANCELED!" G EXIT
Note:
See TracChangeset
for help on using the changeset viewer.
