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