PSGWFLBO ;BHAM ISC/MPH,CML-Enter/Edit Backorders ; 14 Feb 1989 1:49 PM
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
CMT ;PSGWOD-TO BE DISPENSED AMT, PSGWACT-ACTUAL DISP.,PSGWDIN=DA OF 58.3,PSGWDA-AOU NUMBER,PSGWIN-DATE OF BKORD,PSGWAOUN-AOU NAME,SET IN ROUTINE CALLING PSGFLBO
I '$P(PSGWSITE,"^",5),((PSGWOD-PSGWACT)>0) W !,"BACKORDERED ",PSGWOD-PSGWACT
DIC I '$D(PSGWDIN) S DIC="^PSI(58.3,",DIC(0)="N",X=PSGWDN D ^DIC K DIC Q:Y<0 S PSGWDIN=+Y
LOOP S PSGBOT=0,DIE="^PSI(58.3,",DA=PSGWDIN,DR="1///^S X=PSGWAOUN" F J=0:0 S J=$S($D(^PSI(58.3,PSGWDIN,1,PSGWDA,1,J)):$O(^(J)),1:"") Q:J="" D FILLBO
I $P(PSGWSITE,"^",5) G END
NEWBO S PSGWOD=PSGWOD-PSGBOT I PSGWACT<PSGWOD S PSGBKO=PSGWOD-PSGWACT,DR(2,58.31)="1///^S X=PSGWIN",DR(3,58.32)="1///^S X=PSGBKO;2///^S X=PSGBKO" D ^DIE
END K PSGWACT,PSGBKO,PSGBOT,PSGWDIN,PSGWDN,PSGWOD,PSGPIN,PSGQUAN,DIE,DR,DIC,X,DA,J Q
;
FILLBO I $P(^PSI(58.3,PSGWDIN,1,PSGWDA,1,J,0),"^",5)'="" G:$P(^(0),"^",5)<PSGWIN BOTTOM
S PSGQUAN=$P(^PSI(58.3,PSGWDIN,1,PSGWDA,1,J,0),"^",2),PSGPIN=$P(^(0),"^",1)
I PSGWACT'<PSGQUAN S PSGWACT=PSGWACT-PSGQUAN,DR(3,58.32)="4///^S X=PSGWIN"
E S PSGQUAN=PSGQUAN-PSGWACT,DR(3,58.32)="1///^S X=PSGQUAN;3///TODAY;4///@"
DIE S DR(2,58.31)="1///^S X=PSGPIN" D ^DIE
S PSGBOT=PSGBOT+PSGQUAN
BOTTOM Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWFLBO 1287 printed Dec 13, 2024@01:39:24 Page 2
PSGWFLBO ;BHAM ISC/MPH,CML-Enter/Edit Backorders ; 14 Feb 1989 1:49 PM
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
CMT ;PSGWOD-TO BE DISPENSED AMT, PSGWACT-ACTUAL DISP.,PSGWDIN=DA OF 58.3,PSGWDA-AOU NUMBER,PSGWIN-DATE OF BKORD,PSGWAOUN-AOU NAME,SET IN ROUTINE CALLING PSGFLBO
+1 IF '$PIECE(PSGWSITE,"^",5)
IF ((PSGWOD-PSGWACT)>0)
WRITE !,"BACKORDERED ",PSGWOD-PSGWACT
DIC IF '$DATA(PSGWDIN)
SET DIC="^PSI(58.3,"
SET DIC(0)="N"
SET X=PSGWDN
DO ^DIC
KILL DIC
if Y<0
QUIT
SET PSGWDIN=+Y
LOOP SET PSGBOT=0
SET DIE="^PSI(58.3,"
SET DA=PSGWDIN
SET DR="1///^S X=PSGWAOUN"
FOR J=0:0
SET J=$SELECT($DATA(^PSI(58.3,PSGWDIN,1,PSGWDA,1,J)):$ORDER(^(J)),1:"")
if J=""
QUIT
DO FILLBO
+1 IF $PIECE(PSGWSITE,"^",5)
GOTO END
NEWBO SET PSGWOD=PSGWOD-PSGBOT
IF PSGWACT<PSGWOD
SET PSGBKO=PSGWOD-PSGWACT
SET DR(2,58.31)="1///^S X=PSGWIN"
SET DR(3,58.32)="1///^S X=PSGBKO;2///^S X=PSGBKO"
DO ^DIE
END KILL PSGWACT,PSGBKO,PSGBOT,PSGWDIN,PSGWDN,PSGWOD,PSGPIN,PSGQUAN,DIE,DR,DIC,X,DA,J
QUIT
+1 ;
FILLBO IF $PIECE(^PSI(58.3,PSGWDIN,1,PSGWDA,1,J,0),"^",5)'=""
if $PIECE(^(0),"^",5)<PSGWIN
GOTO BOTTOM
+1 SET PSGQUAN=$PIECE(^PSI(58.3,PSGWDIN,1,PSGWDA,1,J,0),"^",2)
SET PSGPIN=$PIECE(^(0),"^",1)
+2 IF PSGWACT'<PSGQUAN
SET PSGWACT=PSGWACT-PSGQUAN
SET DR(3,58.32)="4///^S X=PSGWIN"
+3 IF '$TEST
SET PSGQUAN=PSGQUAN-PSGWACT
SET DR(3,58.32)="1///^S X=PSGQUAN;3///TODAY;4///@"
DIE SET DR(2,58.31)="1///^S X=PSGPIN"
DO ^DIE
+1 SET PSGBOT=PSGBOT+PSGQUAN
BOTTOM QUIT
