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

RMPR5NU1.m

Go to the documentation of this file.
  1. RMPR5NU1 ;HIN/RVD-INVENTORY UPDATE UTILITY ;3/24/1998
  1. ;;3.0;PROSTHETICS;**33,37,53**;Feb 09, 1996
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ADD ;add a new inventory stock record
  1. K Y,DD,DO S DIC="^RMPR(661.2,",DIC(0)="L",X=DT,DLAYGO=661.2 D FILE^DICN K DLAYGO S (RM6612,DA)=+Y
  1. Q:'$D(RMLOC)
  1. D UPD Q:$D(RQUIT)
  1. S ^RMPR(661.2,DA,0)=DT_"^"_RMPRDFN_"^"_RMSO_"^"_RMDAHC_"^^"_RMSER_"^"_DUZ_"^"_RMQTY_"^"_RMIT_"^^^"_RMTOBA_"^^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLOC_"^"_$J(RMAVA,0,2)
  1. S:$D(RMLAB) ^RMPR(661.2,DA,1)=RMTIME_"^"_$J(RMLACO,0,2)
  1. S DIK="^RMPR(661.2," D IX1^DIK
  1. Q
  1. ;
  1. EDIT ;update the current balance.
  1. S RMITEM=$O(^RMPR(661.1,"G",RMITEM,0))
  1. Q:'$D(^RMPR(661.1,RMITEM,3))
  1. D UPD
  1. S DIC="^RMPR(661.2,",DIC(0)="L",X=DT,DLAYGO=661.2 D FILE^DICN G:Y'>0 EXIT S DA=+Y K DLAYGO,DIC,DIC(0),X
  1. S RMMES="Issue from Stock was updated: ("
  1. S ^RMPR(661.2,DA,0)=DT_"^^^^^^^"_RMQTY_"^"_RMITEM_"^^^"_RMBAL_"^"_RMMES_"^"_RMTOCO
  1. S DIK="^RMPR(661.2," D IX1^DIK
  1. Q
  1. ;
  1. UPD ;update item current balance in 661.3
  1. S RMAVCO=0
  1. S RM3=$G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
  1. S RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMAVCO=$P(RM3,U,10)
  1. S RMBA=RMBA-RMQTY S RMCO=RMBA*RMAVCO
  1. S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2)=RMBA
  1. S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,3)=RMCO
  1. ;
  1. BAL ;get total cost of the same HCPCS and ITEM @ the same station.
  1. S RS=RMPR("STA"),(RMTOBA,RMTOCO,RMAVA)=0
  1. F RLO=0:0 S RLO=$O(^RMPR(661.3,"E",RS,RLO)) Q:RLO'>0 I $D(^RMPR(661.3,RLO,1,"B",RMDAHC)) S RHC=$O(^RMPR(661.3,RLO,1,"B",RMDAHC,0)) S RIT=$O(^RMPR(661.3,RLO,1,RHC,1,"B",RMIT,0)) D
  1. .Q:'RIT
  1. .S RENT=$G(^RMPR(661.3,RLO,1,RHC,1,RIT,0))
  1. .S RMBAA=$P(RENT,U,2),RMCOA=$P(RENT,U,3),RMAVA=$P(RENT,U,10),RMSOA=$P(RENT,U,9)
  1. .S RMTOBA=RMTOBA+RMBAA,RMTOCO=RMTOCO+RMCOA
  1. S:RMTOBA RMAVA=RMTOCO/RMTOBA
  1. Q
  1. ;
  1. ;RE = EDIT FLAG
  1. ;RL =location
  1. ;RH = hcpcs IEN (NEW)
  1. ;RHO = hcpcs IEN (OLD)
  1. ;RMLOC,RDESC,RMHCDA = variables created
  1. ;
  1. ITEMLOC(RE,RL,RH,RHO) ;ASK for an Item Location.
  1. ;
  1. N X,Y,DIC,RMLOCC,RMHCC,RMHCC,RMHC,RMLO1,RMLLF,RMLCOUNT,DA
  1. I '$D(^RMPR(661.3,"C",RH)) K RMLOC Q
  1. S RMLLF=0,RMLOCC=0
  1. S RMHCC=$P(^RMPR(661.1,RH,3,0),U,4) S:RMHCC=1 RMLLF=1
  1. S RDESC=$P(^RMPR(661.1,RH,0),U,2)
  1. S RMHC=$P(^RMPR(661.1,RH,0),U,1)
  1. K Y,DIC("B")
  1. ;
  1. LODIC S DIC("S")="I $D(^RMPR(661.3,+Y,1,""B"",RH)),$P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
  1. S DIC("A")="Enter Inventory LOCATION: "
  1. I $G(RE)&(RH=RHO) S DIC("B")=$P(^RMPR(661.3,RL,0),U,1)
  1. S DIC="^RMPR(661.3,",DIC(0)="AENMQ"
  1. D ^DIC K DIC
  1. I $D(DUOUT)!$D(DTOUT)!$D(DIRUT) S RQUIT=1 Q
  1. I +Y'>0 G LODIC
  1. S RL=+Y
  1. ;
  1. LOCPROC ;jump here if only one location
  1. S RMLOC=RL
  1. S RMHCDA=$O(^RMPR(661.3,RL,1,"B",RH,0))
  1. Q
  1. ;
  1. ;RE = edit flag
  1. ;RL = location NEW
  1. ;RO = location old
  1. ;RC = HCPCS entry in 661.3
  1. ;RH = HCPCS NEW
  1. ;RHO = HCPCS OLD
  1. ;RI = PSAS-item#
  1. ;RMDES,RMIT,RMITDA,RMITDES variables created
  1. ITEM(RE,RL,RO,RH,RHO,RC,RI) ;ask for PSAS ITEM
  1. N Y,X,DIC,RMIIF,RMDAHC,RMHCPC,RMHC,RMUBA,RMU3,DA
  1. ;
  1. ITDIC ;
  1. I $G(RE)&(RL=RO)&(RH=RHO) S DIC("B")=$G(RI)
  1. ;S DIC("S")="I $D(^RMPR(661.3,RL,1,RC,1,""B"",Y))"
  1. S DA(2)=RL,DA(1)=RC
  1. S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
  1. S DIC(0)="AEMNQ",DIC("A")="Enter PSAS Item: " D ^DIC K DIC
  1. I $D(DUOUT)!$D(DTOUT) S RQUIT=1 Q
  1. I +Y'>0 G ITDIC
  1. S RMITDA=+Y,(RMITDES,RMIT)=$P(^RMPR(661.3,RL,1,RC,1,+Y,0),U,1)
  1. S RMU3=$G(^RMPR(661.3,RL,1,RC,1,RMITDA,0))
  1. S RMDES=RMIT K DIC("B"),DIC("S")
  1. S RMUBA=$P(RMU3,U,2)
  1. I RMUBA<1 W !,$C(7),"*** ITEM BALANCE is LOW @ this Pros Location......",!,"*** Please ORDER the Item or UPDATE the Inventory Balance."
  1. Q
  1. ;
  1. DSP ;display HCPCS @ a LOCATION
  1. K ^TMP($J) S (RCNT,RMPRI,REND)=0
  1. S RMPRI=0 F S RMPRI=$O(^RMPR(661.3,RMLODA,1,RMPRI)) Q:RMPRI'>0 D
  1. .S RMPRI1=$P(^RMPR(661.3,RMLODA,1,RMPRI,0),U,1),RMPRIT=$P(^RMPR(661.1,RMPRI1,0),U,1),^TMP($J,RMPRIT)=$P(^RMPR(661.1,RMPRI1,0),U,2)
  1. I $D(^TMP($J)) W !,"List of HCPCS at location: ",RMLOC S RI="" F S RI=$O(^TMP($J,RI)) Q:RI=""!(REND) D
  1. .S RCNT=RCNT+1
  1. .I RCNT>16 R !,"Enter <RETURN> for more or ^ to STOP listing",RANS:DTIME S:$D(DTOUT)!$D(DUOUT)!(RANS="^") REND=1 S RCNT=0
  1. .W !,RI,?12,^TMP($J,RI)
  1. LDIC I RFL S X="?",DIC=661.1,DIC(0)="EQM",DIC("W")="W "" "",$P(^RMPR(661.1,+Y,0),U,2) I $P(^RMPR(661.1,+Y,0),U,5)=0 W "" **Inactive HCPCS**""" D ^DIC K RFL
  1. K ^TMP($J),RANS,RCNT,REND,RI,RMPRI,RMPRI1,RMPRIT
  1. Q
  1. ;
  1. VEND() ;
  1. N RMU3
  1. S RMU3=$G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
  1. S Y=$P(RMU3,U,5)
  1. Q Y
  1. ;
  1. ;
  1. BALA() ;
  1. N RMU3
  1. S RMU3=$G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
  1. S Y=$P(RMU3,U,3)
  1. Q Y
  1. ;
  1. COST() ;
  1. N RMU3
  1. S RMU3=$G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
  1. S Y=$P(RMU3,U,10)
  1. Q Y
  1. ;
  1. SOURCE() ;
  1. N RMU3
  1. S RMU3=$G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0))
  1. S Y=$P(RMU3,U,9)
  1. Q Y
  1. ;
  1. CONV ;convert utility for Inventory Location field. (in CAPS)
  1. S RJ=0,RMDAT=X,X=""
  1. PROC S RJ=RJ+1 Q:RJ>$L(RMDAT) S RA=$E(RMDAT,RJ,RJ),RB=$A(RA) D:(RB>96)&(RB<123) ST S:(RB<97)!(RB>123) RMC=RA S X=X_RMC G PROC
  1. ST S RC=RB-32,RMC=$C(RC)
  1. Q
  1. ;
  1. EXIT ;EXIT FOR INVENTORY UPDATE UTILITY
  1. K DLAYGO,DUOUT,DTOUT,DIE,DIC,DA,DR,RMQTY,RMIEN,RMSO,RMLOC,RMBAL,RMPRIEN,RMITEM
  1. Q
  1. NDX ;reindex the 'D1' cross-reference of file 661.3
  1. S DIK(1)=".01^D1"
  1. W !!,"Reindexing 'D1' cross reference of file #661.3...",!
  1. F RI=0:0 S RI=$O(^RMPR(661.3,RI)) Q:RI'>0 F RJ=0:0 S RJ=$O(^RMPR(661.3,RI,1,RJ)) Q:RJ'>0 D
  1. .F RK=0:0 S RK=$O(^RMPR(661.3,RI,1,RJ,1,RK)) Q:RK'>0 I $D(^(RK,0)) D
  1. ..S DA(2)=RI,DA(1)=RJ,DA=RK,DIK="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
  1. ..D EN1^DIK
  1. K RI,RJ,RK,DIK,DA
  1. Q