source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29.m@ 868

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

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1RMPR29 ;PHX/JLT-ENTER/EDIT 2529-3 [ 10/01/94 5:29 AM ]
2 ;;3.0;PROSTHETICS;**12,41,62,128**;Feb 09, 1996
3 ;RVD patch #62 - PCE and suspense link
4CREATE ;CREATE 2529-3
5 K RMPREDIT,RMPRTMP,RMPR25,^TMP($J,"RMPRPCE") D DIV4^RMPRSIT G:$D(X) EXIT1
6 D GETPAT^RMPRUTIL I '$D(RMPRDFN) G EXIT1
7VIEW ;CREATE 2529-3 VIA LAB MENU
8 N RMPRDA,RMPRWO,RMPRJOB S RMPRF=4 D ^RMPRPAT I $D(RMPRKILL) G EXIT
9 S DIC="^RMPR(664.1,",DIC(0)="ZL",X=DT
10 S DLAYGO=664.1 D FILE^DICN K DLAYGO,DIC
11 G:+Y'>0 EXIT1
12 S RMPRDA=+Y,$P(^RMPR(664.1,RMPRDA,0),U,2)=RMPRDFN,$P(^(0),U,3)=RMPR("STA"),$P(^(0),U,17)="I"
13 S IDEF=$$STA^RMPR31U(RMPR("STA"))
14 S DA=RMPRDA,DIK="^RMPR(664.1," D IX1^DIK
15 K DR,DA,DIC,Y,DIE D KVAR^VADPT
16 S DFN=$P(^RMPR(664.1,RMPRDA,0),U,2),VAIP("D")="L"
17 D IN5^VADPT S VAINDT=$P($G(VAIP(3)),U) D INP^VADPT
18 I VAIN(1) S DR=".11R;.04R//^S X=$G(IDEF);2R;12//^S X=$P(VAIN(4),U,2);12.1//^S X=$P(VAIN(2),U,2);12.2//^S X=VAIN(9);12.3//^S X=$P(VAIN(3),U,2);12.4;.09R"
19 I 'VAIN(1) S DR=".11R;.04R//^S X=$G(IDEF);2R;.09R"
20EDT ;EDIT/DELETE 2529-3
21 I $G(RMPRDA)>0,$G(RMPRDA)'="" G ST
22 K DR,DIC D DIV4^RMPRSIT G:$D(X) EXIT1
23 S RMPREDIT=1
24 S DIC="^RMPR(664.1,",DIC(0)="AEQM",DR=".01"
25 ;screen on complete, delete status
26 S DIC("S")="I $P(^(0),U,17)'=""D""&($P(^(0),U,17)'=""C"")"
27 S DIC("W")="D EN3^RMPRD1"
28 D ^DIC K DIC
29 G:+Y'>0 EXIT1 S RMPRDA=+Y
30 I $G(RMPRDA)'>0 Q
31 L +^RMPR(664.1,RMPRDA,0):1
32 I '$T W $C(7),!!,?5,"Someone is already editing this entry" G EXIT
33 D DSP^RMPR29R K DIR
34 S DIR(0)="Y",DIR("A")="Would you like to Edit this Entry"
35 S DIR("B")="YES" D ^DIR
36 G:$D(DTOUT)!($D(DIRUT)) EXIT K DKILL,IKILL G:+Y=0 DEL
37ST ;set data in 2529-3 file
38 S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2),DA=RMPRDA,DIE="^RMPR(664.1,"
39 I '$D(DR),'$D(^RMPR(664.1,RMPRDA,"CDR")) S DR=".11R;.04;2R;.09R"
40 I '$D(DR),$D(^RMPR(664.1,RMPRDA,"CDR")) S DR=".11R;.04R;2R;12;12.1;12.2;12.3;12.4;.09R"
41 D ^DIE G:$D(Y)!($D(DTOUT)) CHK^RMPR29D
42GD ;Display work order
43 D DIS^RMPR29W(RMPRDFN,RMPRDA) G:$G(X)="^" CHK^RMPR29D G:+Y'>0 ITM
44 K DR,DA,DIC,DIE
45 S DIC="^RMPR(664.1,"_RMPRDA_",1,"
46 S DIC("P")="664.15PA",DA(1)=RMPRDA
47 S DIC(0)="EQMZL",X=Y(0,0),ELG=$P(Y(0),U,3)
48 D ^DIC
49 I +Y'>0 K DIC G GD
50 S DIE=DIC K DIC
51 S DA(1)=RMPRDA,DA=+Y
52 S DR="1///^S X=ELG;.01;1"
53 D ^DIE G:$D(DTOUT)!($D(Y)) CHK^RMPR29D G GD
54ITM ;EDIT 2529-3 ITEM
55 K DIR S DA=RMPRDA,DIC="^RMPR(664.1,"_RMPRDA_",2,"
56 S DIC("P")="664.16PA",DA(1)=RMPRDA,DIC(0)="AEQMZL"
57 S DIC("W")="S RA=$P(^(0),U,1) I +RA W ?16,$$ITM^RMPR31U(RA)"
58 D ^DIC K DIC G:+Y'>0 CHK^RMPR29D
59 S RY=$P(Y,U,2) D ITA^RMPR29U(RY)
60 S DA=+Y,DIE="^RMPR(664.1,"_RMPRDA_",2,"
61 S DR="8R;9R;13;7;2R;3R;12"
62 D ^DIE G:$D(DTOUT) CHK^RMPR29D
63 S RMTYPE=$P(^RMPR(664.1,RMPRDA,2,DA,0),U,7)
64 I $D(DA) S RDATA=RMTYPE_"^"_RMPRDA_"^"_DA D CHKCPT^RMPR29U(RDATA)
65 I $D(DA) S RY=$P(^RMPR(664.1,DA(1),2,DA,0),U),HCPCS=$P($G(^(2)),U,1),RMCPT=$P($G(^(2)),U,2) D ITA^RMPR29U(RY)
66 K RMTYPE,RDATA,RMCPT
67D G ITM
68LAB ;ASK TO POST REQUEST
69 S DIR(0)="Y",DIR("A")="Would you like to review this request"
70 S DIR("B")="YES" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EXIT
71 I Y=1 S IOP="HOME" D PRT^RMPR29R
72 K DIR S DIR(0)="Y",DIR("A")="Would you like to post this request"
73 S DIR("B")="YES" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EXIT
74 I +Y=0 W !!,?5,$C(7),"Request not posted!!" G:$D(RMPR25) RDL G EXIT
75 ;set temp transaction flag if needed
76 K RMPRTMP I $P(^RMPR(664.1,RMPRDA,0),U,15)'=RMPR("STA") S RMPRTMP=1
77 S RMPRWO=$P(^RMPR(664.1,RMPRDA,0),U,13) G:RMPRWO'="" SG S SCR=$P(^(0),U,11)
78 D CR^RMPR29U(SCR)
79 I '$D(RMPRWO) W !!,?5,$C(7),"Request not posted!!" G EXIT
80SG ;set 2529-3 global
81 S $P(^RMPR(664.1,RMPRDA,0),U,13)=$G(RMPRWO)
82 ;set no admin count/no lab count
83 I $P(^RMPR(664.1,RMPRDA,0),U,15)=RMPR("STA")&($P(^(0),U,4)'=RMPR("STA")) S $P(^(0),U,23)=1
84 I $P(^RMPR(664.1,RMPRDA,0),U,15)'=RMPR("STA") S $P(^(0),U,20)=1 S:$D(RMPR25) $P(^RMPR(664.1,RMPRDA,0),U,23)=1 S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""PC""" D ^DIE
85 I '$P(^RMPR(664.1,RMPRDA,0),U,20) S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""P""" D ^DIE
86 S $P(^RMPR(664.1,RMPRDA,0),U,5)=DUZ,$P(^(0),U,18)=DT D ^RMPR29A
87 I $G(RMPRWO)'="" W !!,?5,"Assigned Work Order Number: ",RMPRWO D:'$D(RMPRTMP) LOC^RMPR29R
88 ;added by #62
89 I $G(DA660),'$D(^RMPR(660,DA660,10)) D
90 .S (RMPCAMIS,RMPRDFN)=""
91 .S RMPCAMIS=$G(^RMPR(660,DA660,"AMS"))
92 .S:$D(^RMPR(660,DA660,0)) RMPRDFN=$P(^RMPR(660,DA660,0),U,2)
93 .I RMPCAMIS,RMPRDFN S ^TMP($J,"RMPRPCE",660,DA660)=RMPCAMIS_"^"_RMPRDFN
94 ;suspense record inquiry
95 D LINK^RMPRS
96 W !! S DIR(0)="Y",DIR("A")="Would you like to print this 2529-3 request"
97 S DIR("B")="YES" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EXIT
98 I Y=1 D PRT^RMPR29R
99 ;
100EXIT ;common exit point for both RMPR29 and RMPR29A
101 ;
102 L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0)
103 S:$D(RMPR25)&($D(RMPRDA)) RMPRRDA=RMPRDA
104 I '$D(RMPR25)&('$D(RMPREDIT)) W !! S DIR(0)="Y",DIR("A")="Would you like to Process another 2529-3 Request",DIR("B")="YES" D ^DIR G:+Y=1 CREATE
105 D KVAR^VADPT
106 K ^TMP($J,"RMPRPCE")
107 N RMPR,RMPRSITE D KILL^XUSCLEAN
108 Q
109EXIT1 ;exit on error
110 L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0)
111 N RMPR,RMPRSITE D KVAR^VADPT,KILL^XUSCLEAN Q
112DEL ;delete status 2529-3
113 K DIR,Y
114 S DIR(0)="Y",DIR("A")="Would you like to Delete this 2529-3 Entry"
115 S DIR("B")="NO" D ^DIR G:$D(DTOUT)!($D(DIRUT)) EXIT1
116 ;if not drop into edit mode
117 I +Y=0 G:$D(DKILL) GD G:$D(IKILL) ITM G CHK^RMPR29D
118 ;if it has a work order number, only mark as deleted
119 ;delete entry in the 2319 record.
120 N BO
121 S BO=0
122 F S BO=$O(^RMPR(664.1,RMPRDA,2,BO)) Q:BO'>0 D
123 .S DA=$P(^RMPR(664.1,RMPRDA,2,BO,0),U,5)
124 .Q:DA=""
125 .S DIK="^RMPR(660," D ^DIK
126 W !,?5,"Updated 10-2319"
127 K DA,DIK
128 I $P(^RMPR(664.1,RMPRDA,0),U,13)'="" S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""D""" D ^DIE W !,?5,$C(7),"Marked As Deleted..." G EXIT
129RDL ;delete record
130 ;the record is only deleted from 664.1 when the user creats a new
131 ;and then at end say's no do not post. Once it is posted, then
132 ;it must only be marked as deleted.
133 S DA=RMPRDA,DIK="^RMPR(664.1,"
134 D ^DIK K DIK W !!,?5,$C(7),"Deleted..."
135 ;delete the 2319 record
136 N BO
137 S DA=0,BO=0
138 F S BO=$O(^RMPR(664.1,RMPRDA,2,BO)) Q:BO'>0 D
139 .S DA=$P(^RMPR(664.1,RMPRDA,2,BO,0),U,5)
140 .Q:DA=""
141 .S DIK="^RMPR(660," D ^DIK
142 K DIK,DA,RMPRDA
143 W !!,?5,"Updated 10-2319",!
144 G EXIT
Note: See TracBrowser for help on using the repository browser.