RMPR29LC ;HIN/RVD-LAB ISSUE FROM STOCK ;5/27/1998
;;3.0;PROSTHETICS;**33,37,42**;Feb 09, 1996
;Per VHA Directive 10-93-142, this routine should not be modified.
K RMNEW,RMCLOF,RMEDIT,RMFLG D DIV4^RMPRSIT G:$D(X) EXIT
STA S RMUSSN=$P($G(^VA(200,DUZ,1)),U,9) I $D(RMUSSN),(RMUSSN'="") S RMPIEN=$O(^PRSPC("SSN",RMUSSN,0))
I '$D(RMPIEN) S RMQSAL="*** User is not a valid employee...Please contact Personnel..Transaction not closed." W !!,RMQSAL G EXIT
S:RMPIEN RMANSA=$P(^PRSPC(RMPIEN,0),U,29)
I '$D(RMANSA) S RMQSAL="*** Employee is not in PAID Employee file...Please check with Personnel..Transaction not closed." W !!,RMQSAL G EXIT
I $D(RMANSA),('RMANSA) S RMQSAL="*** Employees' SALARY is missing...Please check with Personnel..Transaction not closed." W !!,RMQSAL G EXIT
S:RMANSA RMSAL=(RMANSA/2080)*1.23
;
SEL G:$G(RSTOCK) COM
S DIC="^RMPR(664.1,",DIC(0)="AEMQZ",DIC("S")="I $P(^RMPR(664.1,+Y,0),U,17)=""S""&($P(^(0),U,3)=RMPR(""STA""))"
S DIC("W")="D EN3^RMPRD1"
D ^DIC G:$D(DTOUT)!$D(DTOUT)!(Y'>0) EXIT
L +^RMPR(664.1,+Y):1
I '$T W $C(7),!!,?5,"Someone is already editing this entry" G EXIT
S RMPRDA=+Y,PAC=1
;
COM ;COMPLETE 2529-3
Q:'$G(RMPRDA) K RMEDIT D LIS^RMPR29LU
W !,RMPR("L") K DIR S DIR("A")="Select Processing Action: "
S DIR(0)="SAO^1:EDIT 2529-3 ITEM;2:VIEW PATIENT 2319 ;3:PRINT LAB ISSUE FORM;4:RE-DISPLAY ;5:CANCEL 2529-3",DIR("?")="^D HELP^RMPR29W W !,$C(7),?5,""Enter a number 1-5""" D HELP^RMPR29W
;D ^DIR I X="" S PAGE=PAGE+1 D HD^RMPR29W D:$D(^UTILITY($J,"W"))!$O(^UTILITY("DIQ1",$J,664.16,+RI,7,0)) EXT^RMPR29D D ITD^RMPR29D
D ^DIR G:$D(DUOUT)!$D(DTOUT) EXIT I X="" G POST
I $D(Y),(Y=1) S RMCLOF=1 D TYPE^RMPR29LI G:$D(RMEXIT)!('$D(RMPRDA)) EXIT G COM
I $D(Y),(Y=2) S RFLG=1 D ^RMPRPAT G COM
I $D(Y),(Y=4) G COM
I $D(Y),(Y=5) D DEL^RMPR29LU G:$D(RDEL) SEL G COM
I $D(Y),(Y=3) D PRT^RMPR29R G COM
POST K DIR S DIR(0)="Y",DIR("A")="Do you want to Complete Issuance From Stock",DIR("B")="NO" D ^DIR I +Y=0 W !,"Transaction not completed !!",! Q:$G(RSTOCK) G SEL
;create entry in 664.3
S DIC(0)="L",X=DT K RMRPOST
S RMPRWO=$P(^RMPR(664.1,RMPRDA,0),U,13)
I 'RMPRWO W !,"No Work Order associated with this request...Unable to complete this order...",! G SEL
S RMWODA=$O(^RMPR(664.2,"B",RMPRWO,0))
I 'RMWODA W !,"No Work Order associated with this request...Unable to complete this order...",! G SEL
S RMDAT7=DT_"^"_DT_"^"
S ^RMPR(664.1,RMPRDA,7)=RMDAT7
S $P(^RMPR(664.1,RMPRDA,0),U,16)=DUZ,RITC=$P(^RMPR(664.1,RMPRDA,2,0),U,4)
S RMPRGIP=$P(^RMPR(669.9,RMPRSITE,0),U,3)
F RI=0:0 S RI=$O(^RMPR(664.1,RMPRDA,2,RI)) Q:RI'>0 I $D(^(RI,0)) D
.S RM0=$G(^RMPR(664.1,RMPRDA,2,RI,0))
.S RM3=$G(^RMPR(664.1,RMPRDA,2,RI,3))
.S RM660=$P(RM0,U,5),RMWO=$P(RM0,U,6),RMITEM=$P(RM0,U,1),RMQTY=$P(RM0,U,2)
.I '$G(RM660) W !,"*** Not posted to 2319, Please edit and repost transaction..",! S RMRPOST=1 H 3 Q
.S RMSER=$P(RM0,U,12),RMIT=$P(RM3,U,3),RMSO=$P(RM3,U,1),RMGIP=$P(RM0,U,13)
.S RMUNI=$P(RM0,U,3),RMCOST=$P(RM0,U,4),RMTT=$P(RM0,U,7)
.S RMLOC=$P(RM3,U,4),(RMHCPC,RMDAHC)=$P($G(^RMPR(664.1,RMPRDA,2,RI,2)),U,1)
.I '$G(RMDAHC) W !,"*** Transaction has no HCPCS, Please edit and repost transaction..",! S RMRPOST=1 H 3 Q
.S RMTIME=$P(^RMPR(661.1,RMDAHC,0),U,10)/60,RMLACO=RMSAL*RMTIME,RMLACO=$J(RMLACO,0,2)
.I $G(RMPRGIP)&($G(RMGIP)) D GIP Q:$D(RMEXIT)
.I (RMIT["-")&($G(RMLOC)) D RM6612 ;create entry in 661.2
.S RMTOCO=$P(RM0,U,11)
.S $P(^RMPR(660,RM660,0),U,12)=DT
.S $P(^RMPR(660,RM660,3),U,1)="Veteran"
.S $P(^RMPR(660,RM660,0),U,27)=DUZ
.S $P(^RMPR(660,RM660,0),U,13)=15
.S $P(^RMPR(660,RM660,"LB"),U,6)=RMTIME
.S $P(^RMPR(660,RM660,"LB"),U,7)=$J(RMLACO,0,2)
.S $P(^RMPR(660,RM660,"LB"),U,8)=$J(RMTOCO,0,2)
.S RMTOTC=RMLACO+RMTOCO
.S $P(^RMPR(660,RM660,"LB"),U,9)=$J(RMTOTC,0,2)
.S $P(^RMPR(660,RM660,"LB"),U,11)=DT
.S DIK="^RMPR(660,",DA=RM660 D IX1^DIK
.S DIC="^RMPR(664.3,"
.K DD,DO,DA,DIK D FILE^DICN
.S ^RMPR(664.3,+Y,0)=DT_"^"_RM660_"^"_RMPR("STA")
.S DA=+Y,DIK="^RMPR(664.3," D IX1^DIK K DA,DD,DO
.S ^RMPR(664.3,+Y,1,0)="^664.33PA^1^1",DA(1)=+Y
.S DIC="^RMPR(664.3,"_DA(1)_",1,",DIC(0)="L",X=DUZ
.S RMTIME=RMTIME*($G(RITC))
.S ^RMPR(664.3,DA(1),1,1,0)=DUZ_"^"_RMTIME_"^"_$J(RMSAL,0,2)_"^"
.S DA=1,DIK="^RMPR(664.3,"_DA(1)_",1," D IX1^DIK
.S DIE="^RMPR(664.2,",DA=RMWODA,DR="8////^S X=$G(DT);9////^S X=$G(DUZ)" D ^DIE
G:$G(RMRPOST) COM
S $P(^RMPR(664.2,RMWODA,0),U,10)=DT,DA=RMPRDA G:$D(RMEXIT) EXIT
K DA,Y,DIC,X
S DA=RMPRDA,DR="24////1;33////^S X=DT;20////^S X=DT",DIE="^RMPR(664.1," D ^DIE I $D(DTOUT)!($D(Y)) G EXIT
S:'$P(^RMPR(664.1,RMPRDA,0),U,25) $P(^RMPR(664.1,RMPRDA,0),U,25)=DUZ S $P(^RMPR(664.1,RMPRDA,0),U,26)=DT
W !!,?5,$C(7),"Request Completed and Posted!!!" S DIE="^RMPR(664.1,",DR="16///^S X=""C""",DA=RMPRDA D ^DIE
S DIK=DIE D IX1^DIK K DIK,DA,DR,DIE
Q:$D(RMCOMP)!$G(RSTOCK) G SEL
;END
;
RM6612 S RMLAB=1
S RMHCDA=$O(^RMPR(661.3,RMLOC,1,"B",RMDAHC,0))
I 'RMHCDA S RMEXIT=1 Q
S RMITDA=$O(^RMPR(661.3,RMLOC,1,RMHCDA,1,"B",RMIT,0))
I 'RMITDA S RMEXIT=1 Q
D ADD^RMPR5NU1
K RMLAB
Q
;
GIP S PRCP("QTY")=RMQTY*-1,PRCP("TYP")="R",PRCP("I")=RMGIP,PRCP("ITEM")=$P($G(^RMPR(661,RMITEM,0)),U,1) D ^PRCPUSA
I $D(PRCP("ITEM")) W !!,"Error encountered while posting to GIP. Inventory Issue did not post, Patient 10-2319 not updated!! Please check with your Application Coordinator." H 1 S RMEXIT=1
Q
;
EXIT ;EXIT FOR STOCK ISSUES
L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0) K ^UTILITY("DIQ1",$J)
;W !! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Would you like to Complete and Post another 2529-3" D ^DIR G:+Y=1 SEL
N RMPR,RMPRSITE D KILL^XUSCLEAN Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29LC 5659 printed Dec 13, 2024@02:32:16 Page 2
RMPR29LC ;HIN/RVD-LAB ISSUE FROM STOCK ;5/27/1998
+1 ;;3.0;PROSTHETICS;**33,37,42**;Feb 09, 1996
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 KILL RMNEW,RMCLOF,RMEDIT,RMFLG
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
STA SET RMUSSN=$PIECE($GET(^VA(200,DUZ,1)),U,9)
IF $DATA(RMUSSN)
IF (RMUSSN'="")
SET RMPIEN=$ORDER(^PRSPC("SSN",RMUSSN,0))
+1 IF '$DATA(RMPIEN)
SET RMQSAL="*** User is not a valid employee...Please contact Personnel..Transaction not closed."
WRITE !!,RMQSAL
GOTO EXIT
+2 if RMPIEN
SET RMANSA=$PIECE(^PRSPC(RMPIEN,0),U,29)
+3 IF '$DATA(RMANSA)
SET RMQSAL="*** Employee is not in PAID Employee file...Please check with Personnel..Transaction not closed."
WRITE !!,RMQSAL
GOTO EXIT
+4 IF $DATA(RMANSA)
IF ('RMANSA)
SET RMQSAL="*** Employees' SALARY is missing...Please check with Personnel..Transaction not closed."
WRITE !!,RMQSAL
GOTO EXIT
+5 if RMANSA
SET RMSAL=(RMANSA/2080)*1.23
+6 ;
SEL if $GET(RSTOCK)
GOTO COM
+1 SET DIC="^RMPR(664.1,"
SET DIC(0)="AEMQZ"
SET DIC("S")="I $P(^RMPR(664.1,+Y,0),U,17)=""S""&($P(^(0),U,3)=RMPR(""STA""))"
+2 SET DIC("W")="D EN3^RMPRD1"
+3 DO ^DIC
if $DATA(DTOUT)!$DATA(DTOUT)!(Y'>0)
GOTO EXIT
+4 LOCK +^RMPR(664.1,+Y):1
+5 IF '$TEST
WRITE $CHAR(7),!!,?5,"Someone is already editing this entry"
GOTO EXIT
+6 SET RMPRDA=+Y
SET PAC=1
+7 ;
COM ;COMPLETE 2529-3
+1 if '$GET(RMPRDA)
QUIT
KILL RMEDIT
DO LIS^RMPR29LU
+2 WRITE !,RMPR("L")
KILL DIR
SET DIR("A")="Select Processing Action: "
+3 SET DIR(0)="SAO^1:EDIT 2529-3 ITEM;2:VIEW PATIENT 2319 ;3:PRINT LAB ISSUE FORM;4:RE-DISPLAY ;5:CANCEL 2529-3"
SET DIR("?")="^D HELP^RMPR29W W !,$C(7),?5,""Enter a number 1-5"""
DO HELP^RMPR29W
+4 ;D ^DIR I X="" S PAGE=PAGE+1 D HD^RMPR29W D:$D(^UTILITY($J,"W"))!$O(^UTILITY("DIQ1",$J,664.16,+RI,7,0)) EXT^RMPR29D D ITD^RMPR29D
+5 DO ^DIR
if $DATA(DUOUT)!$DATA(DTOUT)
GOTO EXIT
IF X=""
GOTO POST
+6 IF $DATA(Y)
IF (Y=1)
SET RMCLOF=1
DO TYPE^RMPR29LI
if $DATA(RMEXIT)!('$DATA(RMPRDA))
GOTO EXIT
GOTO COM
+7 IF $DATA(Y)
IF (Y=2)
SET RFLG=1
DO ^RMPRPAT
GOTO COM
+8 IF $DATA(Y)
IF (Y=4)
GOTO COM
+9 IF $DATA(Y)
IF (Y=5)
DO DEL^RMPR29LU
if $DATA(RDEL)
GOTO SEL
GOTO COM
+10 IF $DATA(Y)
IF (Y=3)
DO PRT^RMPR29R
GOTO COM
POST KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to Complete Issuance From Stock"
SET DIR("B")="NO"
DO ^DIR
IF +Y=0
WRITE !,"Transaction not completed !!",!
if $GET(RSTOCK)
QUIT
GOTO SEL
+1 ;create entry in 664.3
+2 SET DIC(0)="L"
SET X=DT
KILL RMRPOST
+3 SET RMPRWO=$PIECE(^RMPR(664.1,RMPRDA,0),U,13)
+4 IF 'RMPRWO
WRITE !,"No Work Order associated with this request...Unable to complete this order...",!
GOTO SEL
+5 SET RMWODA=$ORDER(^RMPR(664.2,"B",RMPRWO,0))
+6 IF 'RMWODA
WRITE !,"No Work Order associated with this request...Unable to complete this order...",!
GOTO SEL
+7 SET RMDAT7=DT_"^"_DT_"^"
+8 SET ^RMPR(664.1,RMPRDA,7)=RMDAT7
+9 SET $PIECE(^RMPR(664.1,RMPRDA,0),U,16)=DUZ
SET RITC=$PIECE(^RMPR(664.1,RMPRDA,2,0),U,4)
+10 SET RMPRGIP=$PIECE(^RMPR(669.9,RMPRSITE,0),U,3)
+11 FOR RI=0:0
SET RI=$ORDER(^RMPR(664.1,RMPRDA,2,RI))
if RI'>0
QUIT
IF $DATA(^(RI,0))
Begin DoDot:1
+12 SET RM0=$GET(^RMPR(664.1,RMPRDA,2,RI,0))
+13 SET RM3=$GET(^RMPR(664.1,RMPRDA,2,RI,3))
+14 SET RM660=$PIECE(RM0,U,5)
SET RMWO=$PIECE(RM0,U,6)
SET RMITEM=$PIECE(RM0,U,1)
SET RMQTY=$PIECE(RM0,U,2)
+15 IF '$GET(RM660)
WRITE !,"*** Not posted to 2319, Please edit and repost transaction..",!
SET RMRPOST=1
HANG 3
QUIT
+16 SET RMSER=$PIECE(RM0,U,12)
SET RMIT=$PIECE(RM3,U,3)
SET RMSO=$PIECE(RM3,U,1)
SET RMGIP=$PIECE(RM0,U,13)
+17 SET RMUNI=$PIECE(RM0,U,3)
SET RMCOST=$PIECE(RM0,U,4)
SET RMTT=$PIECE(RM0,U,7)
+18 SET RMLOC=$PIECE(RM3,U,4)
SET (RMHCPC,RMDAHC)=$PIECE($GET(^RMPR(664.1,RMPRDA,2,RI,2)),U,1)
+19 IF '$GET(RMDAHC)
WRITE !,"*** Transaction has no HCPCS, Please edit and repost transaction..",!
SET RMRPOST=1
HANG 3
QUIT
+20 SET RMTIME=$PIECE(^RMPR(661.1,RMDAHC,0),U,10)/60
SET RMLACO=RMSAL*RMTIME
SET RMLACO=$JUSTIFY(RMLACO,0,2)
+21 IF $GET(RMPRGIP)&($GET(RMGIP))
DO GIP
if $DATA(RMEXIT)
QUIT
+22 ;create entry in 661.2
IF (RMIT["-")&($GET(RMLOC))
DO RM6612
+23 SET RMTOCO=$PIECE(RM0,U,11)
+24 SET $PIECE(^RMPR(660,RM660,0),U,12)=DT
+25 SET $PIECE(^RMPR(660,RM660,3),U,1)="Veteran"
+26 SET $PIECE(^RMPR(660,RM660,0),U,27)=DUZ
+27 SET $PIECE(^RMPR(660,RM660,0),U,13)=15
+28 SET $PIECE(^RMPR(660,RM660,"LB"),U,6)=RMTIME
+29 SET $PIECE(^RMPR(660,RM660,"LB"),U,7)=$JUSTIFY(RMLACO,0,2)
+30 SET $PIECE(^RMPR(660,RM660,"LB"),U,8)=$JUSTIFY(RMTOCO,0,2)
+31 SET RMTOTC=RMLACO+RMTOCO
+32 SET $PIECE(^RMPR(660,RM660,"LB"),U,9)=$JUSTIFY(RMTOTC,0,2)
+33 SET $PIECE(^RMPR(660,RM660,"LB"),U,11)=DT
+34 SET DIK="^RMPR(660,"
SET DA=RM660
DO IX1^DIK
+35 SET DIC="^RMPR(664.3,"
+36 KILL DD,DO,DA,DIK
DO FILE^DICN
+37 SET ^RMPR(664.3,+Y,0)=DT_"^"_RM660_"^"_RMPR("STA")
+38 SET DA=+Y
SET DIK="^RMPR(664.3,"
DO IX1^DIK
KILL DA,DD,DO
+39 SET ^RMPR(664.3,+Y,1,0)="^664.33PA^1^1"
SET DA(1)=+Y
+40 SET DIC="^RMPR(664.3,"_DA(1)_",1,"
SET DIC(0)="L"
SET X=DUZ
+41 SET RMTIME=RMTIME*($GET(RITC))
+42 SET ^RMPR(664.3,DA(1),1,1,0)=DUZ_"^"_RMTIME_"^"_$JUSTIFY(RMSAL,0,2)_"^"
+43 SET DA=1
SET DIK="^RMPR(664.3,"_DA(1)_",1,"
DO IX1^DIK
+44 SET DIE="^RMPR(664.2,"
SET DA=RMWODA
SET DR="8////^S X=$G(DT);9////^S X=$G(DUZ)"
DO ^DIE
End DoDot:1
+45 if $GET(RMRPOST)
GOTO COM
+46 SET $PIECE(^RMPR(664.2,RMWODA,0),U,10)=DT
SET DA=RMPRDA
if $DATA(RMEXIT)
GOTO EXIT
+47 KILL DA,Y,DIC,X
+48 SET DA=RMPRDA
SET DR="24////1;33////^S X=DT;20////^S X=DT"
SET DIE="^RMPR(664.1,"
DO ^DIE
IF $DATA(DTOUT)!($DATA(Y))
GOTO EXIT
+49 if '$PIECE(^RMPR(664.1,RMPRDA,0),U,25)
SET $PIECE(^RMPR(664.1,RMPRDA,0),U,25)=DUZ
SET $PIECE(^RMPR(664.1,RMPRDA,0),U,26)=DT
+50 WRITE !!,?5,$CHAR(7),"Request Completed and Posted!!!"
SET DIE="^RMPR(664.1,"
SET DR="16///^S X=""C"""
SET DA=RMPRDA
DO ^DIE
+51 SET DIK=DIE
DO IX1^DIK
KILL DIK,DA,DR,DIE
+52 if $DATA(RMCOMP)!$GET(RSTOCK)
QUIT
GOTO SEL
+53 ;END
+54 ;
RM6612 SET RMLAB=1
+1 SET RMHCDA=$ORDER(^RMPR(661.3,RMLOC,1,"B",RMDAHC,0))
+2 IF 'RMHCDA
SET RMEXIT=1
QUIT
+3 SET RMITDA=$ORDER(^RMPR(661.3,RMLOC,1,RMHCDA,1,"B",RMIT,0))
+4 IF 'RMITDA
SET RMEXIT=1
QUIT
+5 DO ADD^RMPR5NU1
+6 KILL RMLAB
+7 QUIT
+8 ;
GIP SET PRCP("QTY")=RMQTY*-1
SET PRCP("TYP")="R"
SET PRCP("I")=RMGIP
SET PRCP("ITEM")=$PIECE($GET(^RMPR(661,RMITEM,0)),U,1)
DO ^PRCPUSA
+1 IF $DATA(PRCP("ITEM"))
WRITE !!,"Error encountered while posting to GIP. Inventory Issue did not post, Patient 10-2319 not updated!! Please check with your Application Coordinator."
HANG 1
SET RMEXIT=1
+2 QUIT
+3 ;
EXIT ;EXIT FOR STOCK ISSUES
+1 if +$GET(RMPRDA)
LOCK -^RMPR(664.1,+RMPRDA,0)
KILL ^UTILITY("DIQ1",$JOB)
+2 ;W !! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Would you like to Complete and Post another 2529-3" D ^DIR G:+Y=1 SEL
+3 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
QUIT
