source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRE21.m@ 1801

Last change on this file since 1801 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 6.9 KB
Line 
1RMPRE21 ;PHX/HNC - CLOSE OUT 1358 ;8/29/1994
2 ;;3.0;PROSTHETICS;**12,28,30,34,41,62,78**;Feb 09, 1996
3 ; RMS 08/25/03 Patch #78 - Add shipment date
4 ; RVD #62 - 1/14/02 include an auto-link
5 ;
6EDIT 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
7CL K DIC S DIC="664",DIC(0)="AEQM"
8 S DIC("W")="D EN2^RMPRD1"
9 S DIC("A")="Select PATIENT: "
10 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""))"
11 I RMPRSITE=1 S DIC("S")=DIC("S")_"!($P(RZZZ,U,14)="""")"
12 D ^DIC S (DA,RMPRA)=+Y I Y=-1 K:(X["^")!(X="^") RMPROB G EXIT
13 K DIC G:$P(^RMPR(664,RMPRA,0),U,8) M4 G:$P(^(0),U,5) M6
14 K ^TMP($J),RHCED D GET^RMPRFSH
15 L +^RMPR(664,RMPRA,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT
16 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
17 ;added by #62
18 ;get amis grouper number RGRP1
19 S RGRP1=""
20 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
21 S RGRP1=$P($G(^RMPR(660,RGRPP,"AMS")),U,1)
22 ;
23 ;set shipping entry and collect previous linkage.
24 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)=""
25 D COL^RMPRPCEL
26 ;
27L D ^RMPRLI
28ASK ;ASKS THE USER IF THEY WANT TO CLOSE-OUT THE TRANSACTION
29 S:'$D(RMPRSER) RMPRSER="" K DCT S %=2
30 W !!!,"Ready to Close-Out Transaction"
31 D YN^DICN G:$D(DTOUT) EX G:%=2&(RMPRF=10) EX G:%=1 POST2^RMPRM
32 I %=0 W !!,"You may now Close-out and Post this Transaction. Please answer Yes or No." G ASK
33 I %=-1 W !,"Transaction NOT Closed-Out!" S $P(^RMPR(664,RMPRA,0),U,11)="" K RMPROB G EXIT
34 I '$D(^RMPR(664,RMPRA,1)) S DA=RMPRA,DIE="^RMPR(664,",DR="12" D ^DIE G L
35L1 G:'$D(^RMPR(664,RMPRA,1)) L
36 W !,"Enter Item to Edit: " R X:DTIME G:'$T EXIT
37 G:X["^"!(X="") DS I X["?" D ZDSP^RMPR21A G L1
38 S DIC="^RMPR(664,"_RMPRA_",1,",DIC(0)="EQMZ"
39 D ^DIC G:Y<0 L S RMPRSD=+Y_"^"_Y(0)
40 S DA=+Y,DA(1)=RMPRA,DIE=DIC,RHCOLD=$P($G(^RMPR(664,RMPRA,1,DA,0)),U,16)
41 S RD660=$P($G(^RMPR(664,RMPRA,1,DA,0)),U,13)
42 ;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"
43 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"
44 D ^DIE
45 I '$D(DA) S DIK="^RMPR(660,",DA=RD660,RHCED=1 D ^DIK K RAC,DA,DIK,RMTYPE G CHK
46 ;check for Type of Transaction and update the cpt modifier.
47 D CHKCPT^RMPR21A
48 ;force HCPCS & CPT MODIFIER in 660 even transaction is not closed.
49 S RD660=$P(^RMPR(664,RMPRA,1,DA,0),U,13),RHCNEW=$P(^(0),U,16)
50 S $P(^RMPR(660,RD660,1),U,6)=$P($G(^RMPR(664,RMPRA,1,DA,4)),U,2)
51 I RHCOLD'=RHCNEW S RHCED=1,DA=RD660,DIE="^RMPR(660,",DR="4.5///^S X=$G(RHCNEW)" D ^DIE
52CHK 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
53 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
54 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
55 G L1
56DS W !! S DA=RMPRA,DIE="^RMPR(664,",DR="12;17" D ^DIE G L
57POST1 ;POSTS THE COMPLETED TRANSACTION TO 664,660 AND 424
58 S R1=0
59 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
60 I $D(RMPRWO),+RMPRWO D DA0^RMPR29M(RMPRDA,RMPRA)
61 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
62 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
63 .S DA=$P(^RMPR(664,RMPRA,0),U,12),DIK="^RMPR(660," D IX1^DIK
64 .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
65 ; Prompt for Shipment Date, mark as billable, Patch 78, Added by RMS
66 D ^RMPR4E23
67 I RMPRSH>0&('$P(^RMPR(664,RMPRA,0),U,12))&($P(^(0),U,11)) G PSH
68 W !!,?5,$C(7),"Closed out Transaction"
69 N DA,DIK S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
70 G EX
71PSH S RMPRB=$O(^RMPR(664,RMPRA,1,0))
72 S X=DT,DIC(0)="AEQLM",DLAYGO=660,DIC="^RMPR(660,"
73 S DIC("DR")=".02////^S X="_$P(^RMPR(664,RMPRA,0),U,2)
74 K DINUM,DD,DO D FILE^DICN K DLAYGO
75 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:"")
76 S $P(^RMPR(660,+Y,0),U,14)="C"
77 S $P(^RMPR(660,+Y,0),U,16)=$G(RMPRSH)
78 S $P(^RMPR(660,+Y,0),U,17)=$G(RMPRSH)
79 ;INITIATOR
80 S $P(^RMPR(660,+Y,0),U,27)=$G(DUZ)
81 ;HCPCS code
82 S RMHCPC=$P(^RMPR(664,RMPRA,1,RMPRB,0),U,16)
83 S:RMHCPC $P(^RMPR(660,+Y,0),U,22)=$P(^RMPR(661.1,RMHCPC,0),U,4)
84 S $P(^RMPR(660,+Y,1),U,4)=RMHCPC
85 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)
86 S $P(^RMPR(660,+Y,"AMS"),U,1)=$G(RGRP1)
87 ;
88 ;use da in ix1^dik call
89 S:$D(Y) $P(^RMPR(664,RMPRA,0),U,12)=+Y
90 S INX=+Y
91 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
92 S DA=INX,DIK="^RMPR(660," D IX1^DIK
93 S RM60LINK(INX)=""
94 ;
95 W !!,?5,$C(7),"Closed out 1358 Transaction"
96 N DA,DIK S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
97 ;
98 G EX
99EX D EN1^RMPRFSH L -^RMPR(664,RMPRA,0) I RMPRF'=10,RMPRF'="E" D LINK^RMPRS
100 ;added by #62
101 ;call suspense listmanager screen for multiple suspense and items.
102 I $D(RM60LINK),RMPRF="E",RM68FG>1 D MAN^RMPRPCEL
103 ;
104 ;do auto-link if only one suspense
105 I $D(RM60LINK),RMPRF="E",RM68FG=1 D AUTO^RMPRPCEL
106 K INX,RM68LINK,RM668I,RM660I,RM664DAT,RM668D10,RM60LINK,RMSHIEN,RM68LIFG
107 ;
108 I $D(RMPRF),RMPRF'=10 W !!,"Enter Next Transaction to Close-out, or <RETURN> to Continue."
109 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)
110 K RGRP,RGRP1,RGRPP
111 I $D(RMPRF),RMPRF=10 Q
112 K X G CL
113 ;
114EXIT ;KILL VARIABLES AND EXIT ROUTINE
115 D:$D(^TMP($J))&'$D(RHCED) EN2^RMPRFSH L:$D(RMPRA) -^RMPR(664,RMPRA,0)
116 K PRCSCPAN,LINE,PRCSIP,RMPRAMIS,RMPRCNT,RMPRIT,RMPRIT1,RMPRU,RMPRX,RMPR("AMT"),AMT,BO,PRCSX,PRCS("A"),RMPRA1,RMPRDFN,RMPRNAM,RMPRSSN,RMPRAR
117 K DCT,RMPRTO,RMPRCT,RMPRQT,RMPRSH,RZZZ,R1,B2,%,Y,DIC,R2,RMPRA,RMPRCT,RMPRI,RMPRCONT,DIR,RMX,RHCED,RHCNEW,RHCOLD
118 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
119 I $D(RMPROB) D PRCS^RMPRPSC G:(X'["^")!(X'="^") CL
120 K RMPRF,RMPROB,PRC,RMHCPC,PRCRI,RBL,RDA,RMPRDELN,RMPRWO,RVA Q
121UNK W !,$C(7),"UNKNOWN 2319 RECORD TO UPDATE, IFCAP DAILY RECORD NOT UPDATED!" G EXIT
122M4 W !,$C(7),"This Transaction has already been CLOSED!" G EXIT
123M6 W !,$C(7),"This Transaction has been CANCELED!" G EXIT
Note: See TracBrowser for help on using the repository browser.