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

RMPR5NOR.m

Go to the documentation of this file. 
  1. RMPR5NOR ;HIN/RVD-PROS INVENTORY ORDER/RECEIVE UTILITY ;2/11/98
  1.  ;;3.0;PROSTHETICS;**33,37,46**;Feb 09, 1996
  1.  D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
  1.  S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
  1.  ;
  1.  W @IOF
  1. LOC ;ask for location
  1.  W !!,"Ordering ITEM from Supply or Vendor....",! 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)="AEQM"
  1.  S D="B",DIC("A")="Enter Pros Location: " D MIX^DIC1
  1.  G:$D(DTOUT)!(Y'>0)!$D(DUOUT) EXIT S (DA,RMLODA)=+Y,DIK=DIC
  1.  S RMLOC=$P(^RMPR(661.3,RMLODA,0),U,1)
  1.  I $P(^RMPR(661.3,DA,0),U,3)="" S $P(^(0),U,3)=RMPR("STA") D IX1^DIK
  1.  ;
  1. LIST ;list current HCPCS @ this Location
  1.  K DTOUT,DUOUT,DIC("S"),DIC("B")
  1.  S DIC("A")="Select HCPCS to ORDER: "
  1.  ;S DIR("?")="^S RFL=0 D DSP^RMPR5NU1"
  1.  ;S DIR="^RMPR(661.1," D ^DIR G:(Y="^")!(Y="")!$D(DTOUT)!$D(DUOUT) LOC
  1.  S DIC(0)="AEMQ",DIC("W")="S RZ=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1) I RZ W ?25,$P($G(^RMPR(661.1,RZ,0)),U,2)"
  1.  S DIC="^RMPR(661.3,"_RMLODA_",1," D ^DIC
  1.  I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." G LOC
  1.  S RMHCDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
  1.  ;
  1. L ;list current ITEM for this HCPCS
  1.  K DTOUT,DUOUT,DIC("S")
  1.  S DA(2)=RMLODA,DA(1)=RMHCDA
  1.  S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
  1.  S DIC("A")="Enter Item to ORDER: "
  1.  S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="AEMNQ"
  1.  D ^DIC G:Y'>0!$D(DTOUT)!$D(DUOUT) LIST S RMITDA=+Y
  1.  S (RMITFLG,RMHCFLG,RMAV,RMAVA,RMCO,RMBAL)=0
  1.  S RMIT=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,1)
  1.  S RMDAIT=$P(RMIT,"-",2)
  1.  S RMITEM=$P(^RMPR(661.1,RMDAHC,3,RMDAIT,0),U,1)
  1.  S RMORD=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)
  1.  ;
  1. ORDER ;order item from vendor or supply.
  1.  K DIR,Y S DIR(0)="661.312,31",DIR("A")="Quantity to Order" D ^DIR
  1.  I $D(DUOUT)!$D(DTOUT) W !,"*** Item was not ordered...." H 1 G LOC
  1.  I X="" W $C(7),!,"Enter quantity 1 to 99999.." G ORDER
  1.  S RMORDER=Y K DIR,Y
  1.  S DIE="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
  1.  S DA=RMITDA,DR="31////^S X=$G(RMORDER)" D ^DIE
  1.  S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
  1.  S RMSO=$P(RM3,U,9)
  1.  D BAL^RMPR5NU1
  1.  S X=DT,DIC(0)="AEQL",DLAYGO=661.2,DIC="^RMPR(661.2," K DD,DO
  1.  D FILE^DICN K DLAYGO S RMCOM="Order from supply or vendor"
  1.  S ^RMPR(661.2,+Y,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^"_RMORDER_"^^"_RMTOBA_"^"_RMCOM_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2) S DA=+Y,DIK=DIC D IX1^DIK K Y
  1.  W !,"*** Item ",RMITEM," was ordered...."
  1.  H 1 G LOC
  1.  ;
  1. REC ;receive item from supply, Vendor or Returned Item.
  1.  W @IOF
  1.  D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
  1.  S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
  1.  S X="NOW" D ^%DT S RMDAT1=Y D DD^%DT S RMDAT2=Y
  1. REC1 W !!,"*** Receiving Item from Supply, Vendor or Veteran...",!
  1.  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,",DIC(0)="AEQM"
  1.  S D="B",DIC("A")="Enter Receiving Location: " D MIX^DIC1
  1.  G:$D(DTOUT)!(Y'>0)!$D(DUOUT) EXIT S (DA,RMLODA)=+Y,DIK=DIC
  1.  S RMLOC=$P(^RMPR(661.3,RMLODA,0),U,1)
  1.  I $P(^RMPR(661.3,DA,0),U,3)="" S $P(^(0),U,3)=RMPR("STA") D IX1^DIK
  1.  ;
  1. LITEM ;list current HCPCS @ this Location
  1.  K DTOUT,DUOUT,DIC("S"),DIC("B")
  1.  S DIC("A")="Select HCPCS to RECEIVE: "
  1.  ;S DIR("?")="^S RFL=0 D DSP^RMPR5NU1"
  1.  ;S DIR="^RMPR(661.1," D ^DIR G:(Y="^")!(Y="")!$D(DTOUT)!$D(DUOUT) REC1
  1.  S DIC(0)="AEMQ",DIC("W")="S RZ=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1) I RZ W ?25,$P($G(^RMPR(661.1,RZ,0)),U,2)"
  1.  S DIC="^RMPR(661.3,"_RMLODA_",1," D ^DIC
  1.  I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." H 1 G REC1
  1.  S RMHCDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
  1.  ;
  1.  ;list current ITEM for this HCPCS
  1.  K DTOUT,DUOUT,DIC("S"),DIC("B")
  1.  S DA(2)=RMLODA,DA(1)=RMHCDA
  1.  S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
  1.  S DIC("A")="Enter Item to RECEIVE: "
  1.  S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="AEMNQ"
  1.  D ^DIC G:Y'>0!$D(DTOUT)!$D(DUOUT) LITEM
  1.  S RMITDA=+Y
  1.  ;S RM1=^RMPR(661.1,RMDAHC,3,RMDAIT,0),RMITEM=$P(RM1,U,1)
  1.  S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),RMIT=$P(RM3,U,1)
  1.  S RMQU=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMSO=$P(RM3,U,9)
  1.  ;
  1.  ;update LOCATION.
  1. UPDLOC ;W ! S DIC("A")="Receiving LOCATION: ",DIC="^RMPR(661.3,",DLAYGO=661.3
  1.  ;
  1. UPDQ R !,"Quantity to Receive: ",RMQTREC:DTIME
  1.  G:$D(DTOUT)!$D(DUOUT)!(RMQTREC="^") MESS
  1.  I RMQTREC["?"!(RMQTREC'>0)!(RMQTREC>999) W $C(7),!,"Enter quantity 1 to 999.." G UPDQ
  1.  ;
  1. UPDC ;ask for total Item cost
  1.  K DIR,Y,DA S DIR(0)="661.312,23",DIR("A")="Total Cost of Item " D ^DIR
  1.  G:$D(DUOUT)!$D(DTOUT) MESS
  1.  I X="" W $C(7),!,"Enter Cost 0 to 999999.." G UPDC
  1.  S RMCOREC=Y K DIR,Y
  1.  S RMCOA=RMCO+RMCOREC
  1.  S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,3)=RMCOA
  1.  S RMQUA=RMQU+RMQTREC
  1.  I RMQUA>0 S RMAVA=RMCOA/RMQUA
  1.  I RMQUA<1 S RMAVA=RMCOREC/RMQTREC
  1.  S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,10)=$J(RMAVA,0,2)
  1.  S RMORD=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)
  1.  ;
  1.  ;update Total Item Cost and delete ordered date
  1.  S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,2)=RMQUA
  1.  S RMSO=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,9)
  1.  ;
  1. STAT D BAL^RMPR5NU1
  1.  S X=DT,DIC(0)="AEQL",DLAYGO=661.2,DIC="^RMPR(661.2," K DD,DO
  1.  D FILE^DICN K DLAYGO S RMCOM="Received from supply or vendor"
  1.  S ^RMPR(661.2,+Y,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMQTREC_"^"_RMIT_"^^"_RMQTREC_"^"_RMTOBA_"^"_RMCOM_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2)
  1.  S DA=+Y,DIK=DIC D IX1^DIK
  1.  W !,"****Current Balance @ Location ",$P(^RMPR(661.3,RMLODA,0),U,1)," is now: ",RMQUA
  1.  I RMORD S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)=RMORD-RMQTREC
  1.  H 1 G REC1
  1.  ;
  1. MESS W !,"Nothing Received....."
  1. EXIT ;MAIN EXIT POINT
  1.  N RMPRSITE,RMPR D KILL^XUSCLEAN
  1.  Q