Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPR29LC

RMPR29LC.m

Go to the documentation of this file. 
  1. RMPR29LC ;HIN/RVD-LAB ISSUE FROM STOCK ;5/27/1998
  1.  ;;3.0;PROSTHETICS;**33,37,42**;Feb 09, 1996
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  K RMNEW,RMCLOF,RMEDIT,RMFLG D DIV4^RMPRSIT G:$D(X) EXIT
  1. STA S RMUSSN=$P($G(^VA(200,DUZ,1)),U,9) I $D(RMUSSN),(RMUSSN'="") S RMPIEN=$O(^PRSPC("SSN",RMUSSN,0))
  1.  I '$D(RMPIEN) S RMQSAL="*** User is not a valid employee...Please contact Personnel..Transaction not closed." W !!,RMQSAL G EXIT
  1.  S:RMPIEN RMANSA=$P(^PRSPC(RMPIEN,0),U,29)
  1.  I '$D(RMANSA) S RMQSAL="*** Employee is not in PAID Employee file...Please check with Personnel..Transaction not closed." W !!,RMQSAL G EXIT
  1.  I $D(RMANSA),('RMANSA) S RMQSAL="*** Employees' SALARY is missing...Please check with Personnel..Transaction not closed." W !!,RMQSAL G EXIT
  1.  S:RMANSA RMSAL=(RMANSA/2080)*1.23
  1.  ;
  1. SEL G:$G(RSTOCK) COM
  1.  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""))"
  1.  S DIC("W")="D EN3^RMPRD1"
  1.  D ^DIC G:$D(DTOUT)!$D(DTOUT)!(Y'>0) EXIT
  1.  L +^RMPR(664.1,+Y):1
  1.  I '$T W $C(7),!!,?5,"Someone is already editing this entry" G EXIT
  1.  S RMPRDA=+Y,PAC=1
  1.  ;
  1. COM ;COMPLETE 2529-3
  1.  Q:'$G(RMPRDA)  K RMEDIT D LIS^RMPR29LU
  1.  W !,RMPR("L") K DIR S DIR("A")="Select Processing Action: "
  1.  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
  1.  ;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
  1.  D ^DIR G:$D(DUOUT)!$D(DTOUT) EXIT I X="" G POST
  1.  I $D(Y),(Y=1) S RMCLOF=1 D TYPE^RMPR29LI G:$D(RMEXIT)!('$D(RMPRDA)) EXIT G COM
  1.  I $D(Y),(Y=2) S RFLG=1 D ^RMPRPAT G COM
  1.  I $D(Y),(Y=4) G COM
  1.  I $D(Y),(Y=5) D DEL^RMPR29LU G:$D(RDEL) SEL G COM
  1.  I $D(Y),(Y=3) D PRT^RMPR29R G COM
  1. 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
  1.  ;create entry in 664.3
  1.  S DIC(0)="L",X=DT K RMRPOST
  1.  S RMPRWO=$P(^RMPR(664.1,RMPRDA,0),U,13)
  1.  I 'RMPRWO W !,"No Work Order associated with this request...Unable to complete this order...",! G SEL
  1.  S RMWODA=$O(^RMPR(664.2,"B",RMPRWO,0))
  1.  I 'RMWODA W !,"No Work Order associated with this request...Unable to complete this order...",! G SEL
  1.  S RMDAT7=DT_"^"_DT_"^"
  1.  S ^RMPR(664.1,RMPRDA,7)=RMDAT7
  1.  S $P(^RMPR(664.1,RMPRDA,0),U,16)=DUZ,RITC=$P(^RMPR(664.1,RMPRDA,2,0),U,4)
  1.  S RMPRGIP=$P(^RMPR(669.9,RMPRSITE,0),U,3)
  1.  F RI=0:0 S RI=$O(^RMPR(664.1,RMPRDA,2,RI)) Q:RI'>0  I $D(^(RI,0)) D
  1.  .S RM0=$G(^RMPR(664.1,RMPRDA,2,RI,0))
  1.  .S RM3=$G(^RMPR(664.1,RMPRDA,2,RI,3))
  1.  .S RM660=$P(RM0,U,5),RMWO=$P(RM0,U,6),RMITEM=$P(RM0,U,1),RMQTY=$P(RM0,U,2)
  1.  .I '$G(RM660) W !,"*** Not posted to 2319, Please edit and repost transaction..",! S RMRPOST=1 H 3 Q
  1.  .S RMSER=$P(RM0,U,12),RMIT=$P(RM3,U,3),RMSO=$P(RM3,U,1),RMGIP=$P(RM0,U,13)
  1.  .S RMUNI=$P(RM0,U,3),RMCOST=$P(RM0,U,4),RMTT=$P(RM0,U,7)
  1.  .S RMLOC=$P(RM3,U,4),(RMHCPC,RMDAHC)=$P($G(^RMPR(664.1,RMPRDA,2,RI,2)),U,1)
  1.  .I '$G(RMDAHC) W !,"*** Transaction has no HCPCS, Please edit and repost transaction..",! S RMRPOST=1 H 3 Q
  1.  .S RMTIME=$P(^RMPR(661.1,RMDAHC,0),U,10)/60,RMLACO=RMSAL*RMTIME,RMLACO=$J(RMLACO,0,2)
  1.  .I $G(RMPRGIP)&($G(RMGIP)) D GIP Q:$D(RMEXIT)
  1.  .I (RMIT["-")&($G(RMLOC)) D RM6612 ;create entry in 661.2
  1.  .S RMTOCO=$P(RM0,U,11)
  1.  .S $P(^RMPR(660,RM660,0),U,12)=DT
  1.  .S $P(^RMPR(660,RM660,3),U,1)="Veteran"
  1.  .S $P(^RMPR(660,RM660,0),U,27)=DUZ
  1.  .S $P(^RMPR(660,RM660,0),U,13)=15
  1.  .S $P(^RMPR(660,RM660,"LB"),U,6)=RMTIME
  1.  .S $P(^RMPR(660,RM660,"LB"),U,7)=$J(RMLACO,0,2)
  1.  .S $P(^RMPR(660,RM660,"LB"),U,8)=$J(RMTOCO,0,2)
  1.  .S RMTOTC=RMLACO+RMTOCO
  1.  .S $P(^RMPR(660,RM660,"LB"),U,9)=$J(RMTOTC,0,2)
  1.  .S $P(^RMPR(660,RM660,"LB"),U,11)=DT
  1.  .S DIK="^RMPR(660,",DA=RM660 D IX1^DIK
  1.  .S DIC="^RMPR(664.3,"
  1.  .K DD,DO,DA,DIK D FILE^DICN
  1.  .S ^RMPR(664.3,+Y,0)=DT_"^"_RM660_"^"_RMPR("STA")
  1.  .S DA=+Y,DIK="^RMPR(664.3," D IX1^DIK K DA,DD,DO
  1.  .S ^RMPR(664.3,+Y,1,0)="^664.33PA^1^1",DA(1)=+Y
  1.  .S DIC="^RMPR(664.3,"_DA(1)_",1,",DIC(0)="L",X=DUZ
  1.  .S RMTIME=RMTIME*($G(RITC))
  1.  .S ^RMPR(664.3,DA(1),1,1,0)=DUZ_"^"_RMTIME_"^"_$J(RMSAL,0,2)_"^"
  1.  .S DA=1,DIK="^RMPR(664.3,"_DA(1)_",1," D IX1^DIK
  1.  .S DIE="^RMPR(664.2,",DA=RMWODA,DR="8////^S X=$G(DT);9////^S X=$G(DUZ)" D ^DIE
  1.  G:$G(RMRPOST) COM
  1.  S $P(^RMPR(664.2,RMWODA,0),U,10)=DT,DA=RMPRDA G:$D(RMEXIT) EXIT
  1.  K DA,Y,DIC,X
  1.  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
  1.  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
  1.  W !!,?5,$C(7),"Request Completed and Posted!!!" S DIE="^RMPR(664.1,",DR="16///^S X=""C""",DA=RMPRDA D ^DIE
  1.  S DIK=DIE D IX1^DIK K DIK,DA,DR,DIE
  1.  Q:$D(RMCOMP)!$G(RSTOCK)  G SEL
  1.  ;END
  1.  ;
  1. RM6612 S RMLAB=1
  1.  S RMHCDA=$O(^RMPR(661.3,RMLOC,1,"B",RMDAHC,0))
  1.  I 'RMHCDA S RMEXIT=1 Q
  1.  S RMITDA=$O(^RMPR(661.3,RMLOC,1,RMHCDA,1,"B",RMIT,0))
  1.  I 'RMITDA S RMEXIT=1 Q
  1.  D ADD^RMPR5NU1
  1.  K RMLAB
  1.  Q
  1.  ;
  1. GIP S PRCP("QTY")=RMQTY*-1,PRCP("TYP")="R",PRCP("I")=RMGIP,PRCP("ITEM")=$P($G(^RMPR(661,RMITEM,0)),U,1) D ^PRCPUSA
  1.  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
  1.  Q
  1.  ;
  1. EXIT ;EXIT FOR STOCK ISSUES
  1.  L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0) K ^UTILITY("DIQ1",$J)
  1.  ;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
  1.  N RMPR,RMPRSITE D KILL^XUSCLEAN Q