source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29P.m@ 1766

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1RMPR29P ;PHX/JLT-INITIATE AND PURCHASE LAB ITEMS [ 09/16/94 8:57 AM ]
2 ;;3.0;PROSTHETICS;**20**;Feb 09, 1996
3 ;CALLED FROM RMPR29T
4 ;VARIABLES REQUIRED: RMPRDA - ENTRY NUMBER IN FILE 664.1
5PCH ;initiate purchasing forms from the lab module
6 K DIR,Y D HOME^%ZIS
7 S DIR(0)="S^2421:FORM 2421 PURCHASE;2529:FORM 2529-3 REMOTE REQUEST"
8 S DIR("A")="Select Procurement Form type"
9 D ^DIR
10 I $D(DIRUT)!($D(DUOUT))!(+Y=0) K RMPRF G DISP^RMPR29D
11JB ;SET FORM TYPE IF NOT TIMED OUT OR UP-ARROW OUT
12 S RMPRF=$S(+Y[2421:2,1:4)
13 G DISP^RMPR29J
14 ;exit this routine
15 ;
16STR ;INITIATE 2421 PURCHASE
17 ;CALLED FROM RMPR29J
18 ;VARIABLES REQUIRED: RMPRDA - ENTRY IN FILE 664.1
19 K DIC,DR,DA,DIE
20 ;ask what type of 2421
21 ;
22 S DIR(0)="S^1:PURCHASE CARD 2421;2:IFCAP (1358) 2421"
23 S DIR("A")="Select Type of 2421"
24 W !
25 D ^DIR
26 I $D(DIRUT)!($D(DUOUT))!(+Y=0) K RMPRF G DISP^RMPR29D
27 S RMPRF=+Y
28 ;create initial record in 664
29 S DFN=$P(^RMPR(664.1,RMPRDA,0),U,2)
30 S X=DT,DIC="^RMPR(664,",DIC(0)="LZ" D FILE^DICN Q:+Y'>0
31 S (RMPRK,RMPRA)=+Y
32 S $P(^RMPR(664,RMPRA,0),U,2)=DFN,$P(^(0),U,14)=RMPR("STA"),$P(^(0),U,15)=RMPRWO,$P(^(0),U,16)=DUZ,$P(^(0),U,17)=RMPRDA
33 S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
34 ;
35 ;if visa rmprf=1
36 I RMPRF=1 D 2529^RMPR421 K RMPRF G DISP^RMPR29D
37 ;if 1358 rmprf=2
38OBL ;Check IFCAP access to fund control point
39 ;SEE DBA #282 ;CUSTODIAL PKG - IFCAP ;GRANTED 9/20/93
40 ;CUSTODIAL ISC - WASHINGTON
41 ;
42 S RMPRF=8,PRCS("A")="Select OBLIGATION NUMBER: " D EN1^PRCS58
43 G:Y=-1 END
44 ;display 1358 balance
45 S RMPROB=$P(Y,U,2) D BAL^RMPRPSC
46 S RMPRR="",(RMPRCT,R1,RMPRQT,RMPRTO,RMPRDS,RMPRIS,B2)=0,B1=1
47 S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2),VAPA("P")=1,VAHOW=2
48 D ALL^VADPT S RMPRNAM=^UTILITY("VADM",$J,1)
49 S RMPRDOB=$P(^UTILITY("VADM",$J,3),U)
50 S RMPRSSN=$P(^UTILITY("VADM",$J,2),U)
51 I $D(^UTILITY("VADM",$J,6)) I $P(^UTILITY("VADM",$J,6),U,2)'="" W !!,$C(7),"PATIENT IS DECEASED. DATE OF DEATH WAS ",$P(^UTILITY("VADM",$J,6),U,2)
52 I $D(^UTILITY("VADM",$J,6)) I $P(^UTILITY("VADM",$J,6),U,2)'="" S DIR(0)="Y",DIR("A")="Would you Like to continue Processing this Patient",DIR("B")="NO" D ^DIR K DIR I +Y=0 G END
53 D KVAR^VADPT S RMPRF=2 D VIEW^RMPR21 D:$D(RMPRA) KILL^RMPR21
54END ;exit point
55 ;see internal notes
56 G DISP^RMPR29D
57 ;
582529 ;CREATE 2529-3 RECORD
59 ; CALLED BY RMPR29J
60 ; RMPRDA - ien 664.1
61 S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2),RMPR25=1 D VIEW^RMPR29
62 K RMPRF
63 G:'$D(RMPRRDA) DISP^RMPR29D
64 S $P(^RMPR(664.1,RMPRRDA,0),U,12)=RMPRWO
65 D DEL(RMPRRDA),PST(RMPRRDA) G DISP^RMPR29D
66DEL(RMPRRDA) ;DELETE 2529-3 REQUEST FOR WORK ORDER
67 ; CALLED FROM RMPR29C,RMPR29T
68 ; RMPRDA - ien FILE 664.1
69 F RA=0:0 S RA=$O(^RMPR(664.1,RMPRRDA,2,RA)) Q:RA'>0 S RWO=$P($G(^RMPR(664.1,RMPRRDA,2,RA,0)),U,6) I $D(^RMPR(664.2,"AR3",+RWO,RMPRRDA)) D
70 .F DA=0:0 S DA=$O(^RMPR(664.2,"AR3",RWO,RMPRRDA,DA)) Q:DA'>0 S DA(1)=RWO,DIK="^RMPR(664.2,"_DA(1)_",1," D ^DIK
71 Q
72PST(RMPRRDA) ;Post 2529-3 record to the 2319 patient master record.
73 ; CALLED BYRMPR29T
74 ; RMPRDA - ien FILE 664.1
75 S RMPR("REF")=$P(^RMPR(664.1,RMPRDA,0),U,13),RMPRWO=$P(^(0),U,12)
76 F RDA=0:0 S RA=$O(^RMPR(664.1,RMPRDA,2,RA)) Q:RA'>0 I $D(^(RA,0)) S IT=$P(^(0),U,1),QTY=$P(^(0),U,2),UN=$P(^(0),U,3),RDA=$P(^(0),U,5),SER=$P(^(0),U,12),$P(^(0),U,6)=RMPRWO D
77 .I $D(^RMPR(660,+RDA,0)) S DA=+RDA,DIE="^RMPR(660,",DR="23///^S X=RMPR(""REF"")" D ^DIE S DA=+RDA,DIK="^RMPR(660," D IX^DIK K DD,D0,DO
78 .S DIC="^RMPR(664.2,"_RMPRWO_",1,",DIC("P")="664.22PA",DA(1)=RMPRWO,DIC(0)="LZ",X=IT D FILE^DICN I +Y>0 D
79 ..S $P(^RMPR(664.2,RMPRWO,1,+Y,0),U,2)=QTY,$P(^(0),U,3)="0.00",$P(^(0),U,4)="V",$P(^(0),U,7)=UN,$P(^(0),U,8)=SER,$P(^(0),U,10)=RMPR("REF"),$P(^(0),U,12)=RDA,$P(^(0),U,13)=RMPRRDA S DIK=DIC,DA(1)=RMPRWO,DA=+Y D IX1^DIK
80 Q
Note: See TracBrowser for help on using the repository browser.