RMPR29P ;PHX/JLT-INITIATE AND PURCHASE LAB ITEMS [ 09/16/94  8:57 AM ]
 ;;3.0;PROSTHETICS;**20**;Feb 09, 1996
 ;CALLED FROM RMPR29T
 ;VARIABLES REQUIRED: RMPRDA - ENTRY  NUMBER IN FILE 664.1
PCH ;initiate purchasing forms from the lab module
 K DIR,Y D HOME^%ZIS
 S DIR(0)="S^2421:FORM 2421 PURCHASE;2529:FORM 2529-3 REMOTE REQUEST"
 S DIR("A")="Select Procurement Form type"
 D ^DIR
 I $D(DIRUT)!($D(DUOUT))!(+Y=0) K RMPRF G DISP^RMPR29D
JB ;SET FORM TYPE IF NOT TIMED OUT OR UP-ARROW OUT
 S RMPRF=$S(+Y[2421:2,1:4)
 G DISP^RMPR29J
 ;exit this routine
 ;
STR ;INITIATE 2421 PURCHASE
 ;CALLED FROM RMPR29J
 ;VARIABLES REQUIRED: RMPRDA - ENTRY IN FILE 664.1
 K DIC,DR,DA,DIE
 ;ask what type of 2421
 ;
 S DIR(0)="S^1:PURCHASE CARD 2421;2:IFCAP (1358) 2421"
 S DIR("A")="Select Type of 2421"
 W !
 D ^DIR
 I $D(DIRUT)!($D(DUOUT))!(+Y=0) K RMPRF G DISP^RMPR29D
 S RMPRF=+Y
 ;create initial record in 664
 S DFN=$P(^RMPR(664.1,RMPRDA,0),U,2)
 S X=DT,DIC="^RMPR(664,",DIC(0)="LZ" D FILE^DICN Q:+Y'>0
 S (RMPRK,RMPRA)=+Y
 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
 S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
 ;
 ;if visa rmprf=1
 I RMPRF=1 D 2529^RMPR421 K RMPRF G DISP^RMPR29D
 ;if 1358 rmprf=2
OBL ;Check IFCAP access to fund control point
 ;SEE DBA #282 ;CUSTODIAL PKG - IFCAP  ;GRANTED 9/20/93
 ;CUSTODIAL ISC - WASHINGTON
 ;
 S RMPRF=8,PRCS("A")="Select OBLIGATION NUMBER: " D EN1^PRCS58
 G:Y=-1 END
 ;display 1358 balance
 S RMPROB=$P(Y,U,2) D BAL^RMPRPSC
 S RMPRR="",(RMPRCT,R1,RMPRQT,RMPRTO,RMPRDS,RMPRIS,B2)=0,B1=1
 S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2),VAPA("P")=1,VAHOW=2
 D ALL^VADPT S RMPRNAM=^UTILITY("VADM",$J,1)
 S RMPRDOB=$P(^UTILITY("VADM",$J,3),U)
 S RMPRSSN=$P(^UTILITY("VADM",$J,2),U)
 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)
 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
 D KVAR^VADPT S RMPRF=2 D VIEW^RMPR21 D:$D(RMPRA) KILL^RMPR21
END ;exit point
 ;see internal notes
 G DISP^RMPR29D
 ;
2529 ;CREATE 2529-3 RECORD
 ; CALLED BY RMPR29J
 ; RMPRDA - ien 664.1
 S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2),RMPR25=1 D VIEW^RMPR29
 K RMPRF
 G:'$D(RMPRRDA) DISP^RMPR29D
 S $P(^RMPR(664.1,RMPRRDA,0),U,12)=RMPRWO
 D DEL(RMPRRDA),PST(RMPRRDA) G DISP^RMPR29D
DEL(RMPRRDA) ;DELETE 2529-3 REQUEST FOR WORK ORDER
 ; CALLED FROM RMPR29C,RMPR29T
 ; RMPRDA - ien FILE 664.1
 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
 .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
 Q
PST(RMPRRDA) ;Post 2529-3 record to the 2319 patient master record.
 ; CALLED BYRMPR29T
 ; RMPRDA - ien FILE 664.1
 S RMPR("REF")=$P(^RMPR(664.1,RMPRDA,0),U,13),RMPRWO=$P(^(0),U,12)
 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
 .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
 .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
 ..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
 Q