| [613] | 1 | PSGWBOE ;BHAM ISC/CML-Backorder Input Routine to replace 'PSGW BACKORDER INPUT' Template ; 29 Dec 93 / 8:31 AM
|
|---|
| 2 | ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
|
|---|
| 3 | ITEM ; Select ITEM to be backordered
|
|---|
| 4 | D NOW^%DTC S INDT=$P(%,".") K DA,DIC F QQ=0:0 S (DIC,DLAYGO)="^PSI(58.3,",DIC(0)="QEAMOLZ" W ! D ^DIC K DIC,DLAYGO Q:Y'>0 W ! D MEDRM
|
|---|
| 5 | QUIT K %,%Y,C,D0,D1,D2,DI,DIE,DIG,DIH,DIU,DIV,DQ,DR,GRP,I,INDT,ITEM,ITM,ITMDT,LP,MEDR,MEDRPT,NUM,PC,QQ,X,Y,DA,DIC,DIK Q
|
|---|
| 6 | MEDRM ; Select MED ROOM (AOU)
|
|---|
| 7 | S NUM=+Y,ITM=Y(0) I '$D(^PSI(58.3,NUM,1,0)) S ^(0)="^58.31PA^"
|
|---|
| 8 | F QQ=0:0 K DA S DA(1)=NUM,DIC="^PSI(58.3,"_NUM_",1,",DIC(0)="QEAMLZ" D ^DIC K DIC Q:Y'>0 W ! D DATE
|
|---|
| 9 | K DA I '$O(^PSI(58.3,NUM,1,0)) W *7,!!?5,"Missing MED ROOM data, deleting PHARMACY BACKORDER ITEM entry....",! S DIK="^PSI(58.3,",DA=NUM D ^DIK
|
|---|
| 10 | Q
|
|---|
| 11 | DATE ; Select Backorder Date
|
|---|
| 12 | S MEDR=+Y,MEDRPT=Y(0) I '$D(^PSI(58.1,MEDRPT,1,"B",ITM)) W *7,!!,"The MED ROOM you have chosen does not stock this item!",! S DIK="^PSI(58.3,"_DA(1)_",1,",DA=MEDR D ^DIK K DIK Q
|
|---|
| 13 | S ITEM=$O(^PSI(58.1,+Y,1,"B",ITM,0)),ITMDT=$O(^PSI(58.1,MEDRPT,1,ITEM,"I",0))
|
|---|
| 14 | I ITMDT,ITMDT'>INDT,$P(^PSI(58.1,MEDRPT,1,ITEM,0),"^",9)'="ONE TIME REQ." W *7,!!,"This item is INACTIVE for the MED ROOM you have chosen.",! S DIK="^PSI(58.3,"_NUM_",1,",DA=MEDR D ^DIK K DIK Q
|
|---|
| 15 | I '$D(^PSI(58.3,NUM,1,MEDR,1,0)) S ^(0)="^58.32D^"
|
|---|
| 16 | F QQ=0:0 K DA S DA(2)=NUM,DA(1)=MEDR,DIC="^PSI(58.3,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="QEAML" D ^DIC Q:Y'>0 W ! S DA=+Y,DIE=DIC,DR=1 D ^DIE W ! I X']"" D DELBO
|
|---|
| 17 | K DA I '$O(^PSI(58.3,NUM,1,MEDR,1,0)) W *7,!!?5,"Missing DATE/TIME FOR BACKORDER data, deleting ",$P(^PSI(58.1,MEDRPT,0),"^")," entry...",! S DA(1)=NUM,DA=MEDR,DIK="^PSI(58.3,"_DA(1)_",1," D ^DIK K DIK
|
|---|
| 18 | Q
|
|---|
| 19 | DELBO ;
|
|---|
| 20 | I $D(^PSI(58.3,NUM,1,MEDR,1,DA,0)),$P(^(0),"^",2) Q
|
|---|
| 21 | W *7,!!?5,"Missing CURRENT BACKORDER data, deleting BACKORDER entry...",! S DIK=DIC D ^DIK K DIK Q
|
|---|
