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

RMPR5NAE.m

Go to the documentation of this file. 
  1. RMPR5NAE ;HIN/RVD-PROS INVENTORY ADD UTILITY ;2/11/98
  1.  ;;3.0;PROSTHETICS;**33,37,55**;Feb 09, 1996
  1.  ;
  1.  ;RVD   patch #55  - fix the locking problem and don't allow
  1.  ;                   Fileman to use the number entered as an
  1.  ;                   PSAS/ITEM name
  1.  ;
  1.  D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
  1.  S X="NOW" D ^%DT
  1. LOC ;add location.
  1.  W @IOF,!!,"Adding Item to a Location.....",! K DTOUT,DUOUT,DIC("B")
  1.  S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
  1.  S DIC="^RMPR(661.3,",DLAYGO=661.3,DIC(0)="AEQL"
  1.  S D="B",DIC("A")="Enter Pros Location: " D MIX^DIC1
  1.  G:$D(DTOUT)!$D(DUOUT)!(Y'>0) EXIT S (DA,RMLODA)=+Y
  1.  L +^RMPR(661.3,+Y,0):2
  1.  I '$T W !,"Record in use. Try again later..." H 3 G LOC
  1.  S RMLOC=$P(^RMPR(661.3,+Y,0),U,1),DIK=DIC
  1.  I $P(^RMPR(661.3,DA,0),U,3)="" S $P(^(0),U,3)=RMPR("STA") D IX1^DIK
  1.  L -^RMPR(661.3,RMLODA,0)
  1.  ;
  1. LIST ;list current HCPCS @ this Location
  1.  K DIR,DIC("S") S DIR(0)="FO",DIR("A")="Select HCPCS to ADD ",DIR("?")="^S RFL=1 D DSP^RMPR5NU1"
  1.  S DIR="^RMPR(661.1," D ^DIR G:(Y="^")!(Y="")!$D(DTOUT)!$D(DUOUT) LOC
  1.  S DIC(0)="EMNZ",DIC("S")="I $P(^RMPR(661.1,+Y,0),U,5)=1"
  1.  S DIC=661.1,DIC(0)="ENMZ" D ^DIC G:$D(DTOUT)!$D(DUOUT) LOC
  1.  G:Y="^" LOC
  1.  I +Y'>0 W !,"** No HCPCS Selected or Unable to Select Inactive HCPCS..." G LIST
  1.  S RMDAHC=+Y,RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
  1.  S (RMITFLG,RMHCFLG,RMHCDA,RMITDA,RMAV,RMAVA,RMCO,RMBAL)=0
  1.  S DIC(0)="AEMQ",DA(1)=RMDAHC K DIC("S")
  1. ITEM ;ask for PSAS Item to add
  1.  S DIC("A")="Enter Item to Add: "
  1.  S DIC("B")=$O(^RMPR(661.1,RMDAHC,3,"B",0))
  1.  S DIC="^RMPR(661.1,"_DA(1)_",3,",RDIC1=DIC
  1.  S $P(^RMPR(661.1,DA(1),3,0),U,2)="661.12"
  1.  S DIC(0)="ALEMQ",DLAYGO=661.1 D ^DIC
  1.  G:Y'>0!$D(DTOUT)!$D(DUOUT) LIST S (DA,RMDAIT)=+Y K DIC("B"),DLAYGO
  1.  S DIE=DIC,DR=".01R" D ^DIE
  1.  G:'$D(^RMPR(661.1,RMDAHC,3,RMDAIT,0)) LIST
  1.  S RM1=$G(^RMPR(661.1,RMDAHC,3,RMDAIT,0)) G:RM1="" LIST
  1.  S RMAV=$P(RM1,U,2),RMTOBA=$P(RM1,U,3),RMTOCO=$P(RM1,U,4)
  1.  S $P(^RMPR(661.1,RMDAHC,0),U,9)=1
  1.  S RMITEM=$P(^RMPR(661.1,RMDAHC,3,RMDAIT,0),U,1)
  1.  S RMIT=RMHCPC_"-"_RMDAIT,RMHC=RMDAHC
  1.  ;
  1.  ;for HCPCS in 661.3
  1.  K DIC("A") S DA(1)=RMLODA
  1.  I '$D(^RMPR(661.3,RMLODA,1,"B",RMDAHC)) S X=RMDAHC D
  1.  .S $P(^RMPR(661.3,RMLODA,1,0),U,2)="661.31"
  1.  .K DD,DO S DIC="^RMPR(661.3,"_DA(1)_",1,",DIC(0)="L",DLAYGO=661.3
  1.  .D FILE^DICN Q:Y=-1
  1.  S RMHCDA=$O(^RMPR(661.3,RMLODA,1,"B",RMDAHC,0))
  1.  G:'RMHCDA EXIT
  1.  ;
  1.  ;for item in 661.3
  1.  S DA(2)=RMLODA,DA(1)=RMHCDA
  1.  S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,",RDIC3=DIC
  1.  I '$D(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B",RMIT)) S X=RMIT D
  1.  .S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,0),U,2)="661.312I"
  1.  .K DD,DO S DLAYGO=661.3,DIC(0)="L" D FILE^DICN Q:Y=-1
  1.  S (DA,RMITDA)=$O(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B",RMIT,0))
  1.  G:'RMITDA EXIT
  1.  L +^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA):2
  1.  I '$T W !!,"Record in use. Try again later..." H 3 G LOC
  1.  S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
  1.  S RMQU=$P(RM3,U,2),RMCO=$P(RM3,U,3) S:'RMQU RMQU=0 S:'RMCO RMCO=0
  1.  ;
  1. UPD ;updates item in 661.3
  1.  S (RMAVA,RMQUD,RMCOD)=0
  1.  S DIE=RDIC3,DR="29R",DIE("NO^")="BACK" D ^DIE
  1.  S DR="22R;23R~TOTAL COST OF QUANTITY;24;25R;26;27"
  1.  S DR=DR_";28//^S X=RMITEM" D ^DIE
  1.  S RM3A=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
  1.  S RMQUA=$P(RM3A,U,2),RMCOA=$P(RM3A,U,3),RMAVA=$P(RM3A,U,10),RMSO=$P(RM3A,U,9)
  1.  I (RMSO="C")&(RMCOA<.0001) G LOC
  1.  I RMSO="C" S:(RMAVA<1)&($G(RMQUA)) RMAVA=RMCOA/RMQUA
  1.  I RMCO'=RMCOA S RMCOD=RMCOA-RMCO
  1.  I RMQU'=RMQUA S RMQUD=RMQUA-RMQU
  1.  I RMQUD,'RMCOD S RMCOA=RMAVA*RMQUA
  1.  I 'RMQUD,RMCOD S:RMQUA>0 RMAVA=RMCOA/RMQUA
  1.  I RMQUD,RMCOD S:RMQUA>0 RMAVA=RMCOA/RMQUA
  1.  S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,3)=RMCOA
  1.  S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,8)=RMITEM
  1.  S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,10)=$J(RMAVA,0,2)
  1.  ;
  1. STAT ;create an item statistics for this event.
  1.  G:RMQU=RMQUA&(RMCO=RMCOA) LOC
  1.  D BAL^RMPR5NU1
  1.  L -^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA)
  1.  K DD,DO S DIC="^RMPR(661.2,",DIC(0)="L",X=DT,DLAYGO=661.2 D FILE^DICN
  1.  G:$D(DTOUT)!(Y'>0) LOC S DA=+Y
  1.  S RMMESF="Added/Updated by "_$E($P(^VA(200,DUZ,0),U,1),1,15)_": ("
  1.  S RMMESF=RMMESF_$S(RMQUD>0:"+"_RMQUD_")",1:RMQUD_")")
  1.  S ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMQUD_"^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2) S DIK=DIC D IX1^DIK
  1.  W !!,"** Item ",RMITEM," was ",RMMESF," @ Location ",RMLOC
  1.  H 1 G LIST
  1.  ;
  1. EXIT ;MAIN EXIT POINT
  1.  N RMPRSITE,RMPR D KILL^XUSCLEAN
  1.  Q