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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29P 3744 printed Dec 13, 2024@02:32:24 Page 2
RMPR29P ;PHX/JLT-INITIATE AND PURCHASE LAB ITEMS [ 09/16/94 8:57 AM ]
+1 ;;3.0;PROSTHETICS;**20**;Feb 09, 1996
+2 ;CALLED FROM RMPR29T
+3 ;VARIABLES REQUIRED: RMPRDA - ENTRY NUMBER IN FILE 664.1
PCH ;initiate purchasing forms from the lab module
+1 KILL DIR,Y
DO HOME^%ZIS
+2 SET DIR(0)="S^2421:FORM 2421 PURCHASE;2529:FORM 2529-3 REMOTE REQUEST"
+3 SET DIR("A")="Select Procurement Form type"
+4 DO ^DIR
+5 IF $DATA(DIRUT)!($DATA(DUOUT))!(+Y=0)
KILL RMPRF
GOTO DISP^RMPR29D
JB ;SET FORM TYPE IF NOT TIMED OUT OR UP-ARROW OUT
+1 SET RMPRF=$SELECT(+Y[2421:2,1:4)
+2 GOTO DISP^RMPR29J
+3 ;exit this routine
+4 ;
STR ;INITIATE 2421 PURCHASE
+1 ;CALLED FROM RMPR29J
+2 ;VARIABLES REQUIRED: RMPRDA - ENTRY IN FILE 664.1
+3 KILL DIC,DR,DA,DIE
+4 ;ask what type of 2421
+5 ;
+6 SET DIR(0)="S^1:PURCHASE CARD 2421;2:IFCAP (1358) 2421"
+7 SET DIR("A")="Select Type of 2421"
+8 WRITE !
+9 DO ^DIR
+10 IF $DATA(DIRUT)!($DATA(DUOUT))!(+Y=0)
KILL RMPRF
GOTO DISP^RMPR29D
+11 SET RMPRF=+Y
+12 ;create initial record in 664
+13 SET DFN=$PIECE(^RMPR(664.1,RMPRDA,0),U,2)
+14 SET X=DT
SET DIC="^RMPR(664,"
SET DIC(0)="LZ"
DO FILE^DICN
if +Y'>0
QUIT
+15 SET (RMPRK,RMPRA)=+Y
+16 SET $PIECE(^RMPR(664,RMPRA,0),U,2)=DFN
SET $PIECE(^(0),U,14)=RMPR("STA")
SET $PIECE(^(0),U,15)=RMPRWO
SET $PIECE(^(0),U,16)=DUZ
SET $PIECE(^(0),U,17)=RMPRDA
+17 SET DA=RMPRA
SET DIK="^RMPR(664,"
DO IX1^DIK
+18 ;
+19 ;if visa rmprf=1
+20 IF RMPRF=1
DO 2529^RMPR421
KILL RMPRF
GOTO DISP^RMPR29D
+21 ;if 1358 rmprf=2
OBL ;Check IFCAP access to fund control point
+1 ;SEE DBA #282 ;CUSTODIAL PKG - IFCAP ;GRANTED 9/20/93
+2 ;CUSTODIAL ISC - WASHINGTON
+3 ;
+4 SET RMPRF=8
SET PRCS("A")="Select OBLIGATION NUMBER: "
DO EN1^PRCS58
+5 if Y=-1
GOTO END
+6 ;display 1358 balance
+7 SET RMPROB=$PIECE(Y,U,2)
DO BAL^RMPRPSC
+8 SET RMPRR=""
SET (RMPRCT,R1,RMPRQT,RMPRTO,RMPRDS,RMPRIS,B2)=0
SET B1=1
+9 SET RMPRDFN=$PIECE(^RMPR(664,RMPRA,0),U,2)
SET VAPA("P")=1
SET VAHOW=2
+10 DO ALL^VADPT
SET RMPRNAM=^UTILITY("VADM",$JOB,1)
+11 SET RMPRDOB=$PIECE(^UTILITY("VADM",$JOB,3),U)
+12 SET RMPRSSN=$PIECE(^UTILITY("VADM",$JOB,2),U)
+13 IF $DATA(^UTILITY("VADM",$JOB,6))
IF $PIECE(^UTILITY("VADM",$JOB,6),U,2)'=""
WRITE !!,$CHAR(7),"PATIENT IS DECEASED. DATE OF DEATH WAS ",$PIECE(^UTILITY("VADM",$JOB,6),U,2)
+14 IF $DATA(^UTILITY("VADM",$JOB,6))
IF $PIECE(^UTILITY("VADM",$JOB,6),U,2)'=""
SET DIR(0)="Y"
SET DIR("A")="Would you Like to continue Processing this Patient"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF +Y=0
GOTO END
+15 DO KVAR^VADPT
SET RMPRF=2
DO VIEW^RMPR21
if $DATA(RMPRA)
DO KILL^RMPR21
END ;exit point
+1 ;see internal notes
+2 GOTO DISP^RMPR29D
+3 ;
2529 ;CREATE 2529-3 RECORD
+1 ; CALLED BY RMPR29J
+2 ; RMPRDA - ien 664.1
+3 SET RMPRDFN=$PIECE(^RMPR(664.1,RMPRDA,0),U,2)
SET RMPR25=1
DO VIEW^RMPR29
+4 KILL RMPRF
+5 if '$DATA(RMPRRDA)
GOTO DISP^RMPR29D
+6 SET $PIECE(^RMPR(664.1,RMPRRDA,0),U,12)=RMPRWO
+7 DO DEL(RMPRRDA)
DO PST(RMPRRDA)
GOTO DISP^RMPR29D
DEL(RMPRRDA) ;DELETE 2529-3 REQUEST FOR WORK ORDER
+1 ; CALLED FROM RMPR29C,RMPR29T
+2 ; RMPRDA - ien FILE 664.1
+3 FOR RA=0:0
SET RA=$ORDER(^RMPR(664.1,RMPRRDA,2,RA))
if RA'>0
QUIT
SET RWO=$PIECE($GET(^RMPR(664.1,RMPRRDA,2,RA,0)),U,6)
IF $DATA(^RMPR(664.2,"AR3",+RWO,RMPRRDA))
Begin DoDot:1
+4 FOR DA=0:0
SET DA=$ORDER(^RMPR(664.2,"AR3",RWO,RMPRRDA,DA))
if DA'>0
QUIT
SET DA(1)=RWO
SET DIK="^RMPR(664.2,"_DA(1)_",1,"
DO ^DIK
End DoDot:1
+5 QUIT
PST(RMPRRDA) ;Post 2529-3 record to the 2319 patient master record.
+1 ; CALLED BYRMPR29T
+2 ; RMPRDA - ien FILE 664.1
+3 SET RMPR("REF")=$PIECE(^RMPR(664.1,RMPRDA,0),U,13)
SET RMPRWO=$PIECE(^(0),U,12)
+4 FOR RDA=0:0
SET RA=$ORDER(^RMPR(664.1,RMPRDA,2,RA))
if RA'>0
QUIT
IF $DATA(^(RA,0))
SET IT=$PIECE(^(0),U,1)
SET QTY=$PIECE(^(0),U,2)
SET UN=$PIECE(^(0),U,3)
SET RDA=$PIECE(^(0),U,5)
SET SER=$PIECE(^(0),U,12)
SET $PIECE(^(0),U,6)=RMPRWO
Begin DoDot:1
+5 IF $DATA(^RMPR(660,+RDA,0))
SET DA=+RDA
SET DIE="^RMPR(660,"
SET DR="23///^S X=RMPR(""REF"")"
DO ^DIE
SET DA=+RDA
SET DIK="^RMPR(660,"
DO IX^DIK
KILL DD,D0,DO
+6 SET DIC="^RMPR(664.2,"_RMPRWO_",1,"
SET DIC("P")="664.22PA"
SET DA(1)=RMPRWO
SET DIC(0)="LZ"
SET X=IT
DO FILE^DICN
IF +Y>0
Begin DoDot:2
+7 SET $PIECE(^RMPR(664.2,RMPRWO,1,+Y,0),U,2)=QTY
SET $PIECE(^(0),U,3)="0.00"
SET $PIECE(^(0),U,4)="V"
SET $PIECE(^(0),U,7)=UN
SET $PIECE(^(0),U,8)=SER
SET $PIECE(^(0),U,10)=RMPR("REF")
SET $PIECE(^(0),U,12)=RDA
SET $PIECE(^(0),U,13)=RMPRRDA
SET DIK=DIC
SET DA(1)=RMPRWO
SET DA=+Y
DO IX1^DIK
End DoDot:2
End DoDot:1
+8 QUIT
