Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRE21

RMPRE21.m

Go to the documentation of this file. 
  1. RMPRE21 ;PHX/HNC - CLOSE OUT 1358 ;8/29/1994
  1.  ;;3.0;PROSTHETICS;**12,28,30,34,41,62,78**;Feb 09, 1996
  1.  ; RMS 08/25/03 Patch #78 - Add shipment date
  1.  ; RVD #62 - 1/14/02 include an auto-link
  1.  ;
  1. EDIT K ^TMP($J) S PRCS("A")="Select OBLIGATION NUMBER: " D EN1^PRCS58 G:Y=-1 EXIT S RMPR("OB")=$P(Y(0),U,1),RMPROB=$P(Y,U,2) D BAL^RMPRPSC
  1. CL K DIC S DIC="664",DIC(0)="AEQM"
  1.  S DIC("W")="D EN2^RMPRD1"
  1.  S DIC("A")="Select PATIENT: "
  1.  S DIC("S")="S RZZZ=^(0) I $P(RZZZ,U,3)=RMPROB,('$P(RZZZ,U,8)&'$P(RZZZ,U,5)),($P(RZZZ,U,14)=RMPR(""STA""))"
  1.  I RMPRSITE=1 S DIC("S")=DIC("S")_"!($P(RZZZ,U,14)="""")"
  1.  D ^DIC S (DA,RMPRA)=+Y I Y=-1 K:(X["^")!(X="^") RMPROB G EXIT
  1.  K DIC G:$P(^RMPR(664,RMPRA,0),U,8) M4 G:$P(^(0),U,5) M6
  1.  K ^TMP($J),RHCED D GET^RMPRFSH
  1.  L +^RMPR(664,RMPRA,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT
  1.  S (RMPRDFN,DFN)=$P(^RMPR(664,RMPRA,0),U,2),RMPRWO=$P(^(0),U,15),RMPRDA=$P(^(0),U,17),RMPRNAM=$P(^DPT(DFN,0),U,1),RMPRSSN=$P(^(0),U,9) K RZZZ
  1.  ;added by #62
  1.  ;get amis grouper number RGRP1
  1.  S RGRP1=""
  1.  S RGRP=$O(^RMPR(664,RMPRA,1,0)) G:'RGRP L S RGRPP=$P($G(^RMPR(664,RMPRA,1,RGRP,0)),U,13) I 'RGRPP G L
  1.  S RGRP1=$P($G(^RMPR(660,RGRPP,"AMS")),U,1)
  1.  ;
  1.  ;set shipping entry and collect previous linkage.
  1.  I $P(^RMPR(664,RMPRA,0),U,12) S RMSHIEN=$P(^RMPR(664,RMPRA,0),U,12) S:'$D(^RMPR(660,RMSHIEN,10)) RM60LINK(RMSHIEN)=""
  1.  D COL^RMPRPCEL
  1.  ;
  1. L D ^RMPRLI
  1. ASK ;ASKS THE USER IF THEY WANT TO CLOSE-OUT THE TRANSACTION
  1.  S:'$D(RMPRSER) RMPRSER="" K DCT S %=2
  1.  W !!!,"Ready to Close-Out Transaction"
  1.  D YN^DICN G:$D(DTOUT) EX G:%=2&(RMPRF=10) EX G:%=1 POST2^RMPRM
  1.  I %=0 W !!,"You may now Close-out and Post this Transaction.  Please answer Yes or No." G ASK
  1.  I %=-1 W !,"Transaction NOT Closed-Out!" S $P(^RMPR(664,RMPRA,0),U,11)="" K RMPROB G EXIT
  1.  I '$D(^RMPR(664,RMPRA,1)) S DA=RMPRA,DIE="^RMPR(664,",DR="12" D ^DIE G L
  1. L1 G:'$D(^RMPR(664,RMPRA,1)) L
  1.  W !,"Enter Item to Edit: " R X:DTIME G:'$T EXIT
  1.  G:X["^"!(X="") DS I X["?" D ZDSP^RMPR21A G L1
  1.  S DIC="^RMPR(664,"_RMPRA_",1,",DIC(0)="EQMZ"
  1.  D ^DIC G:Y<0 L S RMPRSD=+Y_"^"_Y(0)
  1.  S DA=+Y,DA(1)=RMPRA,DIE=DIC,RHCOLD=$P($G(^RMPR(664,RMPRA,1,DA,0)),U,16)
  1.  S RD660=$P($G(^RMPR(664,RMPRA,1,DA,0)),U,13)
  1.  ;S DR=".01;1;15;6;3;16;8;9;I $P(^RMPR(664,DA(1),1,DA,0),U,10)'=4 S Y="""";10"
  1.  S DR="8;9;S RMTYPE=$P(^RMPR(664,DA(1),1,DA,0),U,9);I $P(^RMPR(664,DA(1),1,DA,0),U,10)=4 S Y=10;.01;16;1;15;6;3;S Y="""";10;.01;16;1;15;6;3"
  1.  D ^DIE
  1.  I '$D(DA) S DIK="^RMPR(660,",DA=RD660,RHCED=1 D ^DIK K RAC,DA,DIK,RMTYPE G CHK
  1.  ;check for Type of Transaction and update the cpt modifier.
  1.  D CHKCPT^RMPR21A
  1.  ;force HCPCS & CPT MODIFIER in 660 even transaction is not closed.
  1.  S RD660=$P(^RMPR(664,RMPRA,1,DA,0),U,13),RHCNEW=$P(^(0),U,16)
  1.  S $P(^RMPR(660,RD660,1),U,6)=$P($G(^RMPR(664,RMPRA,1,DA,4)),U,2)
  1.  I RHCOLD'=RHCNEW S RHCED=1,DA=RD660,DIE="^RMPR(660,",DR="4.5///^S X=$G(RHCNEW)" D ^DIE
  1. CHK S FL=1 I $D(^RMPR(664,RMPRA,1)) S FL=0 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0  I $D(^(RI,0)) S FL=1
  1.  I 'FL W !!,$C(7),?5,"REQUIRED ITEMS DO NOT EXIST ON THIS FORM",!,?8,"THIS TRANSACTION HAS BEEN CANCELED",! S RMPRAR=$P(^RMPR(664,RMPRA,0),U,12),$P(^(0),U,12)="" D:RMPRAR K660^RMPRC21
  1.  I 'FL S X=$P(^RMPR(664,RMPRA,0),U,7),DIC=424,DIC(0)="MZ" D ^DIC S $P(B2,U,7)=+Y,B3=Y(0) G C58^RMPRC21
  1.  G L1
  1. DS W !! S DA=RMPRA,DIE="^RMPR(664,",DR="12;17" D ^DIE G L
  1. POST1 ;POSTS THE COMPLETED TRANSACTION TO 664,660 AND 424
  1.  S R1=0
  1.  F  S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0  S RMPRAR=$S($P(^RMPR(664,RMPRA,1,R1,0),U,13)'="":$P(^(0),U,13),1:"NP") Q:R1'>0  G:'$D(^RMPR(660,+RMPRAR,0)) UNK D ^RMPRE22
  1.  I $D(RMPRWO),+RMPRWO D DA0^RMPR29M(RMPRDA,RMPRA)
  1.  I $P(^RMPR(664,RMPRA,0),U,10)>0&($P(^(0),U,11)=0)&($P(^(0),U,12)) S DA=$P(^(0),U,12),DIK="^RMPR(660," D ^DIK
  1.  I $P(^RMPR(664,RMPRA,0),U,12)&(RMPRSH>0) S $P(^RMPR(660,$P(^RMPR(664,RMPRA,0),U,12),0),U,16)=RMPRSH,$P(^(0),U,12)=DT D
  1.  .S DA=$P(^RMPR(664,RMPRA,0),U,12),DIK="^RMPR(660," D IX1^DIK
  1.  .I $D(RMPRWO),$D(^RMPR(664.2,+RMPRWO,0)) S $P(^RMPR(664.2,RMPRWO,0),U,7)=$P(^(0),U,7)+RMPRSH D POST^RMPR29U
  1.  ; Prompt for Shipment Date, mark as billable, Patch 78, Added by RMS
  1.  D ^RMPR4E23
  1.  I RMPRSH>0&('$P(^RMPR(664,RMPRA,0),U,12))&($P(^(0),U,11)) G PSH
  1.  W !!,?5,$C(7),"Closed out Transaction"
  1.  N DA,DIK S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
  1.  G EX
  1. PSH S RMPRB=$O(^RMPR(664,RMPRA,1,0))
  1.  S X=DT,DIC(0)="AEQLM",DLAYGO=660,DIC="^RMPR(660,"
  1.  S DIC("DR")=".02////^S X="_$P(^RMPR(664,RMPRA,0),U,2)
  1.  K DINUM,DD,DO D FILE^DICN K DLAYGO
  1.  S ^RMPR(660,+Y,0)=DT_U_RMPRDFN_U_$P(^RMPR(664,RMPRA,0),U)_"^X^^^^^"_$P(^(0),U,4)_U_RMPR("STA")_U_$P(^RMPR(664,RMPRA,1,RMPRB,0),U,15)_U_DT_U_$S($P(^RMPR(660,$P(^RMPR(664,RMPRA,1,RMPRB,0),U,13),0),U,13):$P(^(0),U,13),1:"")
  1.  S $P(^RMPR(660,+Y,0),U,14)="C"
  1.  S $P(^RMPR(660,+Y,0),U,16)=$G(RMPRSH)
  1.  S $P(^RMPR(660,+Y,0),U,17)=$G(RMPRSH)
  1.  ;INITIATOR
  1.  S $P(^RMPR(660,+Y,0),U,27)=$G(DUZ)
  1.  ;HCPCS code
  1.  S RMHCPC=$P(^RMPR(664,RMPRA,1,RMPRB,0),U,16)
  1.  S:RMHCPC $P(^RMPR(660,+Y,0),U,22)=$P(^RMPR(661.1,RMHCPC,0),U,4)
  1.  S $P(^RMPR(660,+Y,1),U,4)=RMHCPC
  1.  S ^RMPR(660,+Y,"AM")=U_U_$P(^RMPR(664,RMPRA,1,RMPRB,0),U,10)_U_$P(^RMPR(664,RMPRA,1,RMPRB,0),U,11)
  1.  S $P(^RMPR(660,+Y,"AMS"),U,1)=$G(RGRP1)
  1.  ;
  1.  ;use da in ix1^dik call
  1.  S:$D(Y) $P(^RMPR(664,RMPRA,0),U,12)=+Y
  1.  S INX=+Y
  1.  I $D(RMPRWO),$D(^RMPR(664.2,+RMPRWO,0)) N Y S $P(^("AM"),U,2)=1 S $P(^RMPR(664.2,RMPRWO,0),U,7)=$P(^RMPR(664.2,RMPRWO,0),U,7)+RMPRSH D DA0^RMPR29M(RMPRDA,RMPRA),POST^RMPR29U
  1.  S DA=INX,DIK="^RMPR(660," D IX1^DIK
  1.  S RM60LINK(INX)=""
  1.  ;
  1.  W !!,?5,$C(7),"Closed out 1358 Transaction"
  1.  N DA,DIK S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
  1.  ;
  1.  G EX
  1. EX D EN1^RMPRFSH L -^RMPR(664,RMPRA,0) I RMPRF'=10,RMPRF'="E" D LINK^RMPRS
  1.  ;added by #62
  1.  ;call suspense listmanager screen for multiple suspense and items.
  1.  I $D(RM60LINK),RMPRF="E",RM68FG>1 D MAN^RMPRPCEL
  1.  ;
  1.  ;do auto-link if only one suspense
  1.  I $D(RM60LINK),RMPRF="E",RM68FG=1 D AUTO^RMPRPCEL
  1.  K INX,RM68LINK,RM668I,RM660I,RM664DAT,RM668D10,RM60LINK,RMSHIEN,RM68LIFG
  1.  ;
  1.  I $D(RMPRF),RMPRF'=10 W !!,"Enter Next Transaction to Close-out, or <RETURN> to Continue."
  1.  K RMPR("AMT"),RMPRAR,RMPRSER,RMPRTO,RMPRCT,RMPRQT,RMPRSH,RZZZ,R1,B2,%,Y,DIC,R2,RMPRA,RMPRCTDA,DIE,DIK,DR,RMPR("DRN"),RMPR("DDT"),DCT,DIR,B3,RMPRB K ^TMP($J)
  1.  K RGRP,RGRP1,RGRPP
  1.  I $D(RMPRF),RMPRF=10 Q
  1.  K X G CL
  1.  ;
  1. EXIT ;KILL VARIABLES AND EXIT ROUTINE
  1.  D:$D(^TMP($J))&'$D(RHCED) EN2^RMPRFSH L:$D(RMPRA) -^RMPR(664,RMPRA,0)
  1.  K PRCSCPAN,LINE,PRCSIP,RMPRAMIS,RMPRCNT,RMPRIT,RMPRIT1,RMPRU,RMPRX,RMPR("AMT"),AMT,BO,PRCSX,PRCS("A"),RMPRA1,RMPRDFN,RMPRNAM,RMPRSSN,RMPRAR
  1.  K DCT,RMPRTO,RMPRCT,RMPRQT,RMPRSH,RZZZ,R1,B2,%,Y,DIC,R2,RMPRA,RMPRCT,RMPRI,RMPRCONT,DIR,RMX,RHCED,RHCNEW,RHCOLD
  1.  K RMPRSER,FL,RMPRN,RMPRI1,RA,DIRUT,DA,DFN,DIE,DIK,DR,RMPR("DRN"),RMPR("DDT"),RMPR("OB"),RD,RC,RIT,RIN,RZ,RT,RF,RE,RAC,RMPRSD,DCTZ,ACT,RI,RMPRP,RMPR90,RMPRAMT,RMPRPSC,^TMP($J),B2,RMPRCC,B3,J,K,DIR,PQTY,RD660
  1.  I $D(RMPROB) D PRCS^RMPRPSC G:(X'["^")!(X'="^") CL
  1.  K RMPRF,RMPROB,PRC,RMHCPC,PRCRI,RBL,RDA,RMPRDELN,RMPRWO,RVA Q
  1. UNK W !,$C(7),"UNKNOWN 2319 RECORD TO UPDATE, IFCAP DAILY RECORD NOT UPDATED!" G EXIT
  1. M4 W !,$C(7),"This Transaction has already been CLOSED!" G EXIT
  1. M6 W !,$C(7),"This Transaction has been CANCELED!" G EXIT