| 1 | RMPR5NOR ;HIN/RVD-PROS INVENTORY ORDER/RECEIVE UTILITY ;2/11/98
|
---|
| 2 | ;;3.0;PROSTHETICS;**33,37,46**;Feb 09, 1996
|
---|
| 3 | D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
|
---|
| 4 | S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
|
---|
| 5 | ;
|
---|
| 6 | W @IOF
|
---|
| 7 | LOC ;ask for location
|
---|
| 8 | W !!,"Ordering ITEM from Supply or Vendor....",! K DTOUT,DUOUT,DIC("B")
|
---|
| 9 | S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
|
---|
| 10 | S DIC="^RMPR(661.3,",DLAYGO=661.3,DIC(0)="AEQM"
|
---|
| 11 | S D="B",DIC("A")="Enter Pros Location: " D MIX^DIC1
|
---|
| 12 | G:$D(DTOUT)!(Y'>0)!$D(DUOUT) EXIT S (DA,RMLODA)=+Y,DIK=DIC
|
---|
| 13 | S RMLOC=$P(^RMPR(661.3,RMLODA,0),U,1)
|
---|
| 14 | I $P(^RMPR(661.3,DA,0),U,3)="" S $P(^(0),U,3)=RMPR("STA") D IX1^DIK
|
---|
| 15 | ;
|
---|
| 16 | LIST ;list current HCPCS @ this Location
|
---|
| 17 | K DTOUT,DUOUT,DIC("S"),DIC("B")
|
---|
| 18 | S DIC("A")="Select HCPCS to ORDER: "
|
---|
| 19 | ;S DIR("?")="^S RFL=0 D DSP^RMPR5NU1"
|
---|
| 20 | ;S DIR="^RMPR(661.1," D ^DIR G:(Y="^")!(Y="")!$D(DTOUT)!$D(DUOUT) LOC
|
---|
| 21 | 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)"
|
---|
| 22 | S DIC="^RMPR(661.3,"_RMLODA_",1," D ^DIC
|
---|
| 23 | I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." G LOC
|
---|
| 24 | S RMHCDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
|
---|
| 25 | ;
|
---|
| 26 | L ;list current ITEM for this HCPCS
|
---|
| 27 | K DTOUT,DUOUT,DIC("S")
|
---|
| 28 | S DA(2)=RMLODA,DA(1)=RMHCDA
|
---|
| 29 | S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
|
---|
| 30 | S DIC("A")="Enter Item to ORDER: "
|
---|
| 31 | S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="AEMNQ"
|
---|
| 32 | D ^DIC G:Y'>0!$D(DTOUT)!$D(DUOUT) LIST S RMITDA=+Y
|
---|
| 33 | S (RMITFLG,RMHCFLG,RMAV,RMAVA,RMCO,RMBAL)=0
|
---|
| 34 | S RMIT=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,1)
|
---|
| 35 | S RMDAIT=$P(RMIT,"-",2)
|
---|
| 36 | S RMITEM=$P(^RMPR(661.1,RMDAHC,3,RMDAIT,0),U,1)
|
---|
| 37 | S RMORD=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)
|
---|
| 38 | ;
|
---|
| 39 | ORDER ;order item from vendor or supply.
|
---|
| 40 | K DIR,Y S DIR(0)="661.312,31",DIR("A")="Quantity to Order" D ^DIR
|
---|
| 41 | I $D(DUOUT)!$D(DTOUT) W !,"*** Item was not ordered...." H 1 G LOC
|
---|
| 42 | I X="" W $C(7),!,"Enter quantity 1 to 99999.." G ORDER
|
---|
| 43 | S RMORDER=Y K DIR,Y
|
---|
| 44 | S DIE="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
|
---|
| 45 | S DA=RMITDA,DR="31////^S X=$G(RMORDER)" D ^DIE
|
---|
| 46 | S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
|
---|
| 47 | S RMSO=$P(RM3,U,9)
|
---|
| 48 | D BAL^RMPR5NU1
|
---|
| 49 | S X=DT,DIC(0)="AEQL",DLAYGO=661.2,DIC="^RMPR(661.2," K DD,DO
|
---|
| 50 | D FILE^DICN K DLAYGO S RMCOM="Order from supply or vendor"
|
---|
| 51 | 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
|
---|
| 52 | W !,"*** Item ",RMITEM," was ordered...."
|
---|
| 53 | H 1 G LOC
|
---|
| 54 | ;
|
---|
| 55 | REC ;receive item from supply, Vendor or Returned Item.
|
---|
| 56 | W @IOF
|
---|
| 57 | D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
|
---|
| 58 | S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
|
---|
| 59 | S X="NOW" D ^%DT S RMDAT1=Y D DD^%DT S RMDAT2=Y
|
---|
| 60 | REC1 W !!,"*** Receiving Item from Supply, Vendor or Veteran...",!
|
---|
| 61 | K DTOUT,DUOUT,DIC("B")
|
---|
| 62 | S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
|
---|
| 63 | S DIC="^RMPR(661.3,",DIC(0)="AEQM"
|
---|
| 64 | S D="B",DIC("A")="Enter Receiving Location: " D MIX^DIC1
|
---|
| 65 | G:$D(DTOUT)!(Y'>0)!$D(DUOUT) EXIT S (DA,RMLODA)=+Y,DIK=DIC
|
---|
| 66 | S RMLOC=$P(^RMPR(661.3,RMLODA,0),U,1)
|
---|
| 67 | I $P(^RMPR(661.3,DA,0),U,3)="" S $P(^(0),U,3)=RMPR("STA") D IX1^DIK
|
---|
| 68 | ;
|
---|
| 69 | LITEM ;list current HCPCS @ this Location
|
---|
| 70 | K DTOUT,DUOUT,DIC("S"),DIC("B")
|
---|
| 71 | S DIC("A")="Select HCPCS to RECEIVE: "
|
---|
| 72 | ;S DIR("?")="^S RFL=0 D DSP^RMPR5NU1"
|
---|
| 73 | ;S DIR="^RMPR(661.1," D ^DIR G:(Y="^")!(Y="")!$D(DTOUT)!$D(DUOUT) REC1
|
---|
| 74 | 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)"
|
---|
| 75 | S DIC="^RMPR(661.3,"_RMLODA_",1," D ^DIC
|
---|
| 76 | I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." H 1 G REC1
|
---|
| 77 | S RMHCDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
|
---|
| 78 | ;
|
---|
| 79 | ;list current ITEM for this HCPCS
|
---|
| 80 | K DTOUT,DUOUT,DIC("S"),DIC("B")
|
---|
| 81 | S DA(2)=RMLODA,DA(1)=RMHCDA
|
---|
| 82 | S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
|
---|
| 83 | S DIC("A")="Enter Item to RECEIVE: "
|
---|
| 84 | S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="AEMNQ"
|
---|
| 85 | D ^DIC G:Y'>0!$D(DTOUT)!$D(DUOUT) LITEM
|
---|
| 86 | S RMITDA=+Y
|
---|
| 87 | ;S RM1=^RMPR(661.1,RMDAHC,3,RMDAIT,0),RMITEM=$P(RM1,U,1)
|
---|
| 88 | S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),RMIT=$P(RM3,U,1)
|
---|
| 89 | S RMQU=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMSO=$P(RM3,U,9)
|
---|
| 90 | ;
|
---|
| 91 | ;update LOCATION.
|
---|
| 92 | UPDLOC ;W ! S DIC("A")="Receiving LOCATION: ",DIC="^RMPR(661.3,",DLAYGO=661.3
|
---|
| 93 | ;
|
---|
| 94 | UPDQ R !,"Quantity to Receive: ",RMQTREC:DTIME
|
---|
| 95 | G:$D(DTOUT)!$D(DUOUT)!(RMQTREC="^") MESS
|
---|
| 96 | I RMQTREC["?"!(RMQTREC'>0)!(RMQTREC>999) W $C(7),!,"Enter quantity 1 to 999.." G UPDQ
|
---|
| 97 | ;
|
---|
| 98 | UPDC ;ask for total Item cost
|
---|
| 99 | K DIR,Y,DA S DIR(0)="661.312,23",DIR("A")="Total Cost of Item " D ^DIR
|
---|
| 100 | G:$D(DUOUT)!$D(DTOUT) MESS
|
---|
| 101 | I X="" W $C(7),!,"Enter Cost 0 to 999999.." G UPDC
|
---|
| 102 | S RMCOREC=Y K DIR,Y
|
---|
| 103 | S RMCOA=RMCO+RMCOREC
|
---|
| 104 | S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,3)=RMCOA
|
---|
| 105 | S RMQUA=RMQU+RMQTREC
|
---|
| 106 | I RMQUA>0 S RMAVA=RMCOA/RMQUA
|
---|
| 107 | I RMQUA<1 S RMAVA=RMCOREC/RMQTREC
|
---|
| 108 | S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,10)=$J(RMAVA,0,2)
|
---|
| 109 | S RMORD=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)
|
---|
| 110 | ;
|
---|
| 111 | ;update Total Item Cost and delete ordered date
|
---|
| 112 | S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,2)=RMQUA
|
---|
| 113 | S RMSO=$P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,9)
|
---|
| 114 | ;
|
---|
| 115 | STAT D BAL^RMPR5NU1
|
---|
| 116 | S X=DT,DIC(0)="AEQL",DLAYGO=661.2,DIC="^RMPR(661.2," K DD,DO
|
---|
| 117 | D FILE^DICN K DLAYGO S RMCOM="Received from supply or vendor"
|
---|
| 118 | 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)
|
---|
| 119 | S DA=+Y,DIK=DIC D IX1^DIK
|
---|
| 120 | W !,"****Current Balance @ Location ",$P(^RMPR(661.3,RMLODA,0),U,1)," is now: ",RMQUA
|
---|
| 121 | I RMORD S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,11)=RMORD-RMQTREC
|
---|
| 122 | H 1 G REC1
|
---|
| 123 | ;
|
---|
| 124 | MESS W !,"Nothing Received....."
|
---|
| 125 | EXIT ;MAIN EXIT POINT
|
---|
| 126 | N RMPRSITE,RMPR D KILL^XUSCLEAN
|
---|
| 127 | Q
|
---|