- PSGWBOE ;BHAM ISC/CML-Backorder Input Routine to replace 'PSGW BACKORDER INPUT' Template ; 29 Dec 93 / 8:31 AM
- ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
- ITEM ; Select ITEM to be backordered
- 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
- 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
- MEDRM ; Select MED ROOM (AOU)
- S NUM=+Y,ITM=Y(0) I '$D(^PSI(58.3,NUM,1,0)) S ^(0)="^58.31PA^"
- 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
- 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
- Q
- DATE ; Select Backorder Date
- 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
- S ITEM=$O(^PSI(58.1,+Y,1,"B",ITM,0)),ITMDT=$O(^PSI(58.1,MEDRPT,1,ITEM,"I",0))
- 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
- I '$D(^PSI(58.3,NUM,1,MEDR,1,0)) S ^(0)="^58.32D^"
- 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
- 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
- Q
- DELBO ;
- I $D(^PSI(58.3,NUM,1,MEDR,1,DA,0)),$P(^(0),"^",2) Q
- W *7,!!?5,"Missing CURRENT BACKORDER data, deleting BACKORDER entry...",! S DIK=DIC D ^DIK K DIK Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWBOE 1885 printed Feb 18, 2025@23:05:20 Page 2
- PSGWBOE ;BHAM ISC/CML-Backorder Input Routine to replace 'PSGW BACKORDER INPUT' Template ; 29 Dec 93 / 8:31 AM
- +1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
- ITEM ; Select ITEM to be backordered
- +1 DO NOW^%DTC
- SET INDT=$PIECE(%,".")
- KILL DA,DIC
- FOR QQ=0:0
- SET (DIC,DLAYGO)="^PSI(58.3,"
- SET DIC(0)="QEAMOLZ"
- WRITE !
- DO ^DIC
- KILL DIC,DLAYGO
- if Y'>0
- QUIT
- WRITE !
- DO MEDRM
- QUIT KILL %,%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
- QUIT
- MEDRM ; Select MED ROOM (AOU)
- +1 SET NUM=+Y
- SET ITM=Y(0)
- IF '$DATA(^PSI(58.3,NUM,1,0))
- SET ^(0)="^58.31PA^"
- +2 FOR QQ=0:0
- KILL DA
- SET DA(1)=NUM
- SET DIC="^PSI(58.3,"_NUM_",1,"
- SET DIC(0)="QEAMLZ"
- DO ^DIC
- KILL DIC
- if Y'>0
- QUIT
- WRITE !
- DO DATE
- +3 KILL DA
- IF '$ORDER(^PSI(58.3,NUM,1,0))
- WRITE *7,!!?5,"Missing MED ROOM data, deleting PHARMACY BACKORDER ITEM entry....",!
- SET DIK="^PSI(58.3,"
- SET DA=NUM
- DO ^DIK
- +4 QUIT
- DATE ; Select Backorder Date
- +1 SET MEDR=+Y
- SET MEDRPT=Y(0)
- IF '$DATA(^PSI(58.1,MEDRPT,1,"B",ITM))
- WRITE *7,!!,"The MED ROOM you have chosen does not stock this item!",!
- SET DIK="^PSI(58.3,"_DA(1)_",1,"
- SET DA=MEDR
- DO ^DIK
- KILL DIK
- QUIT
- +2 SET ITEM=$ORDER(^PSI(58.1,+Y,1,"B",ITM,0))
- SET ITMDT=$ORDER(^PSI(58.1,MEDRPT,1,ITEM,"I",0))
- +3 IF ITMDT
- IF ITMDT'>INDT
- IF $PIECE(^PSI(58.1,MEDRPT,1,ITEM,0),"^",9)'="ONE TIME REQ."
- WRITE *7,!!,"This item is INACTIVE for the MED ROOM you have chosen.",!
- SET DIK="^PSI(58.3,"_NUM_",1,"
- SET DA=MEDR
- DO ^DIK
- KILL DIK
- QUIT
- +4 IF '$DATA(^PSI(58.3,NUM,1,MEDR,1,0))
- SET ^(0)="^58.32D^"
- +5 FOR QQ=0:0
- KILL DA
- SET DA(2)=NUM
- SET DA(1)=MEDR
- SET DIC="^PSI(58.3,"_DA(2)_",1,"_DA(1)_",1,"
- SET DIC(0)="QEAML"
- DO ^DIC
- if Y'>0
- QUIT
- WRITE !
- SET DA=+Y
- SET DIE=DIC
- SET DR=1
- DO ^DIE
- WRITE !
- IF X']""
- DO DELBO
- +6 KILL DA
- IF '$ORDER(^PSI(58.3,NUM,1,MEDR,1,0))
- WRITE *7,!!?5,"Missing DATE/TIME FOR BACKORDER data, deleting ",$PIECE(^PSI(58.1,MEDRPT,0),"^")," entry...",!
- SET DA(1)=NUM
- SET DA=MEDR
- SET DIK="^PSI(58.3,"_DA(1)_",1,"
- DO ^DIK
- KILL DIK
- +7 QUIT
- DELBO ;
- +1 IF $DATA(^PSI(58.3,NUM,1,MEDR,1,DA,0))
- IF $PIECE(^(0),"^",2)
- QUIT
- +2 WRITE *7,!!?5,"Missing CURRENT BACKORDER data, deleting BACKORDER entry...",!
- SET DIK=DIC
- DO ^DIK
- KILL DIK
- QUIT
