- PSGWBO ;BHAM ISC/MPH,CML-Enter/Edit Actual Dispensed/Backorder Values ; 09 Dec 93 / 3:10 PM
- ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
- I '$D(PSGWSITE) D ^PSGWSET Q:'$D(PSGWSITE) S PSGWFLG=1
- I '$D(PSGWIDA) S DIC="^PSI(58.19,",DIC(0)="QEAMNZ",DIC("A")="SELECT DATE/TIME FOR INVENTORY: " D ^DIC K DIC Q:Y<0 S PSGWIDA=+Y,X1=DT,X2=$P($P(Y,"^",2),".") D ^%DTC
- I '$D(^PSI(58.19,"AINV",PSGWIDA)) W !!,$S(X<101:"INVENTORY SHEET MUST BE PRINTED BEFORE ON-HAND AMOUNTS MAY BE ENTERED",1:"INVENTORY OVER 100 DAYS OLD CANNOT BE EDITED") G END
- ;
- EN1 ; PSGWIDA = DA of inventory being edited
- K PSGW("PO") S PSGWV="AMIS COMPILE FLAG"
- F SK=0:0 S SK=$O(^PSI(58.19,PSGWIDA,1,"C",SK)) Q:'SK F J=0:0 S J=$O(^PSI(58.19,PSGWIDA,1,"C",SK,J)) Q:'J S PSGW("PO",SK,J)=""
- S (PSGWADT,PSGWIN)=$P(^PSI(58.19,PSGWIDA,0),"^",1),PSGWCAT="A",FLG=0,AMISFL=0
- WLOOP F PSGSORTK=0:0 S PSGSORTK=$O(PSGW("PO",PSGSORTK)) Q:'PSGSORTK Q:FLG F PSGDA=0:0 S PSGDA=$O(PSGW("PO",PSGSORTK,PSGDA)) D:'PSGDA RESET Q:'PSGDA D WENT Q:FLG S AMISFL=0
- END W ! K PSGW("PO"),DLAYGO,I,J,K,K1,PSG1,PSG2,PSG3,PSGWACT,PSGWAOUN,PSGWDA,PSGDDA,PSGWDIN,PSGWDN,PSGDR,PSGWOD,PSGSORTK,PSGWIN,PSGWN,PSGX,PSGDA,PSGTYP,PSGWIDA,SK,X,Y,A,PSGWADT,PSGWCAT,PSGWQD,FLG,AMISFL,PSGWAOU,KEY,PSGWV,DA,%,%Y,LP,PC
- K TPSG1,TPSG2,TPSG3,TEMPDR,TYP,DIC,DIE,DR K:$D(PSGWFLG) PSGWFLG,PSGWSITE
- Q
- WENT S PSGWN=$S($D(^PSI(58.1,PSGDA,0)):$P(^(0),"^",1),1:""),DIC("B")=PSGWN,DIC("A")="Select AREA OF USE: ",DIC("S")="I $D(^PSI(58.19,PSGWIDA,1,""B"",+Y,+Y))"
- W ! S DIC="^PSI(58.1,",DIC(0)="AEQNMZ" D ^DIC K DIC S (PSGWDA,DA,PSGWAOU)=+Y,PSGWAOUN=$P(Y,"^",2) S:Y<0 FLG=1 Q:Y<0 S:($P(^PSI(58.1,PSGWDA,0),"^",3)'=1)&($P(PSGWSITE,"^",25)=1) AMISFL=1
- S PSG1=""
- PSG1 S PSG1=$O(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1)) Q:PSG1="" S PSG2=""
- PSG2 S PSG2=$O(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2)) G PSG1:PSG2="" S PSG3=""
- PSG3 S PSG3=$O(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3)) G PSG2:PSG3="" S PSGTYP=""
- PSGTYP S PSGTYP=$O(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3,PSGTYP)) G PSG3:PSGTYP="" S PSGDR=""
- PSGDR S PSGDR=$O(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR)) G PSGTYP:PSGDR=""
- I $P(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR),"^",4)'="",$P(^(PSGDR),"^",4)'>-1 G PSGDR
- S PSGDDA=+^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR),PSGWDN=$P(^(PSGDR),"^",2)
- S TEMPDR=PSGDR W !!,"ITEM: ",PSGDR
- I '$D(^PSI(58.1,PSGWDA,1,PSGDDA,1,PSGWIDA,0)) G PSGDR
- S A=^PSI(58.1,PSGWDA,1,PSGDDA,1,PSGWIDA,0) S (PSGX(5),PSGWOD)=$P(A,"^",5)
- DIS W !,"DISPENSE QUANTITY: " W:PSGX(5)'="" PSGX(5),"// " R X:DTIME S:'$T FLG=1 Q:'$T G:X="" EXP Q:X="^" I X["^" D GETVAL^PSGWBO1 G:DA<0 DIS G PSGDR
- I "?"[$E(X)!(X<0)!(X>9999)!(X'?1N.N) W *7,!,"Enter number between 0 and 9999 which is the quantity dispensed." G DIS
- I X D CHKQTY^PSGWBO1 I $D(QTYFLG) K QTYFLG W !!,"ITEM: ",PSGDR G DIS
- S PSGX(5)=$S(X="@":"",1:X),$P(^PSI(58.1,PSGWDA,1,PSGDDA,1,PSGWIDA,0),"^",5)=PSGX(5),PSGWACT=PSGX(5)
- S PSGWQD=PSGX(5)-PSGWOD I (AMISFL=1)&(PSGWQD'=0) S ^PSI(58.5,"AMIS",$H,PSGWADT,PSGWCAT,PSGWAOU,PSGWDN,PSGWQD)=""
- S ^(PSGDR)=$P(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR),"^",1,3)_"^"_PSGX(5)
- I $P(PSGWSITE,"^",5) S DIC(0)=""
- E S DIC(0)="QL",DLAYGO="^PSI(58.3,"
- S DIC="^PSI(58.3,",X="`"_PSGWDN D ^DIC I Y'<0 S PSGWDIN=+Y D ^PSGWFLBO
- ;
- EXP I $P(^PSI(58.1,PSGWDA,0),"^",4) S DA(1)=PSGWDA,DA=PSGDDA,DIE="^PSI(58.1,"_DA(1)_",1,",DR=35 D ^DIE K DIE,DIC
- G PSGDR
- RESET ; Reset Sort key if AOUs taken out of order
- I $O(PSGW("PO",PSGSORTK,0))'=PSGWAOU F J=0:0 S J=$O(PSGW("PO",J)) Q:'J I $O(PSGW("PO",J,0))=PSGWAOU S PSGSORTK=J Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWBO 3651 printed Mar 13, 2025@20:43:33 Page 2
- PSGWBO ;BHAM ISC/MPH,CML-Enter/Edit Actual Dispensed/Backorder Values ; 09 Dec 93 / 3:10 PM
- +1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
- +2 IF '$DATA(PSGWSITE)
- DO ^PSGWSET
- if '$DATA(PSGWSITE)
- QUIT
- SET PSGWFLG=1
- +3 IF '$DATA(PSGWIDA)
- SET DIC="^PSI(58.19,"
- SET DIC(0)="QEAMNZ"
- SET DIC("A")="SELECT DATE/TIME FOR INVENTORY: "
- DO ^DIC
- KILL DIC
- if Y<0
- QUIT
- SET PSGWIDA=+Y
- SET X1=DT
- SET X2=$PIECE($PIECE(Y,"^",2),".")
- DO ^%DTC
- +4 IF '$DATA(^PSI(58.19,"AINV",PSGWIDA))
- WRITE !!,$SELECT(X<101:"INVENTORY SHEET MUST BE PRINTED BEFORE ON-HAND AMOUNTS MAY BE ENTERED",1:"INVENTORY OVER 100 DAYS OLD CANNOT BE EDITED")
- GOTO END
- +5 ;
- EN1 ; PSGWIDA = DA of inventory being edited
- +1 KILL PSGW("PO")
- SET PSGWV="AMIS COMPILE FLAG"
- +2 FOR SK=0:0
- SET SK=$ORDER(^PSI(58.19,PSGWIDA,1,"C",SK))
- if 'SK
- QUIT
- FOR J=0:0
- SET J=$ORDER(^PSI(58.19,PSGWIDA,1,"C",SK,J))
- if 'J
- QUIT
- SET PSGW("PO",SK,J)=""
- +3 SET (PSGWADT,PSGWIN)=$PIECE(^PSI(58.19,PSGWIDA,0),"^",1)
- SET PSGWCAT="A"
- SET FLG=0
- SET AMISFL=0
- WLOOP FOR PSGSORTK=0:0
- SET PSGSORTK=$ORDER(PSGW("PO",PSGSORTK))
- if 'PSGSORTK
- QUIT
- if FLG
- QUIT
- FOR PSGDA=0:0
- SET PSGDA=$ORDER(PSGW("PO",PSGSORTK,PSGDA))
- if 'PSGDA
- DO RESET
- if 'PSGDA
- QUIT
- DO WENT
- if FLG
- QUIT
- SET AMISFL=0
- END WRITE !
- KILL PSGW("PO"),DLAYGO,I,J,K,K1,PSG1,PSG2,PSG3,PSGWACT,PSGWAOUN,PSGWDA,PSGDDA,PSGWDIN,PSGWDN,PSGDR,PSGWOD,PSGSORTK,PSGWIN,PSGWN,PSGX,PSGDA,PSGTYP,PSGWIDA,SK,X,Y,A,PSGWADT,PSGWCAT,PSGWQD,FLG,AMISFL,PSGWAOU,KEY,PSGWV,DA,%,%Y,LP,PC
- +1 KILL TPSG1,TPSG2,TPSG3,TEMPDR,TYP,DIC,DIE,DR
- if $DATA(PSGWFLG)
- KILL PSGWFLG,PSGWSITE
- +2 QUIT
- WENT SET PSGWN=$SELECT($DATA(^PSI(58.1,PSGDA,0)):$PIECE(^(0),"^",1),1:"")
- SET DIC("B")=PSGWN
- SET DIC("A")="Select AREA OF USE: "
- SET DIC("S")="I $D(^PSI(58.19,PSGWIDA,1,""B"",+Y,+Y))"
- +1 WRITE !
- SET DIC="^PSI(58.1,"
- SET DIC(0)="AEQNMZ"
- DO ^DIC
- KILL DIC
- SET (PSGWDA,DA,PSGWAOU)=+Y
- SET PSGWAOUN=$PIECE(Y,"^",2)
- if Y<0
- SET FLG=1
- if Y<0
- QUIT
- if ($PIECE(^PSI(58.1,PSGWDA,0),"^",3)'=1)&($PIECE(PSGWSITE,"^",25)=1)
- SET AMISFL=1
- +2 SET PSG1=""
- PSG1 SET PSG1=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1))
- if PSG1=""
- QUIT
- SET PSG2=""
- PSG2 SET PSG2=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2))
- if PSG2=""
- GOTO PSG1
- SET PSG3=""
- PSG3 SET PSG3=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3))
- if PSG3=""
- GOTO PSG2
- SET PSGTYP=""
- PSGTYP SET PSGTYP=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3,PSGTYP))
- if PSGTYP=""
- GOTO PSG3
- SET PSGDR=""
- PSGDR SET PSGDR=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR))
- if PSGDR=""
- GOTO PSGTYP
- +1 IF $PIECE(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR),"^",4)'=""
- IF $PIECE(^(PSGDR),"^",4)'>-1
- GOTO PSGDR
- +2 SET PSGDDA=+^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR)
- SET PSGWDN=$PIECE(^(PSGDR),"^",2)
- +3 SET TEMPDR=PSGDR
- WRITE !!,"ITEM: ",PSGDR
- +4 IF '$DATA(^PSI(58.1,PSGWDA,1,PSGDDA,1,PSGWIDA,0))
- GOTO PSGDR
- +5 SET A=^PSI(58.1,PSGWDA,1,PSGDDA,1,PSGWIDA,0)
- SET (PSGX(5),PSGWOD)=$PIECE(A,"^",5)
- DIS WRITE !,"DISPENSE QUANTITY: "
- if PSGX(5)'=""
- WRITE PSGX(5),"// "
- READ X:DTIME
- if '$TEST
- SET FLG=1
- if '$TEST
- QUIT
- if X=""
- GOTO EXP
- if X="^"
- QUIT
- IF X["^"
- DO GETVAL^PSGWBO1
- if DA<0
- GOTO DIS
- GOTO PSGDR
- +1 IF "?"[$EXTRACT(X)!(X<0)!(X>9999)!(X'?1N.N)
- WRITE *7,!,"Enter number between 0 and 9999 which is the quantity dispensed."
- GOTO DIS
- +2 IF X
- DO CHKQTY^PSGWBO1
- IF $DATA(QTYFLG)
- KILL QTYFLG
- WRITE !!,"ITEM: ",PSGDR
- GOTO DIS
- +3 SET PSGX(5)=$SELECT(X="@":"",1:X)
- SET $PIECE(^PSI(58.1,PSGWDA,1,PSGDDA,1,PSGWIDA,0),"^",5)=PSGX(5)
- SET PSGWACT=PSGX(5)
- +4 SET PSGWQD=PSGX(5)-PSGWOD
- IF (AMISFL=1)&(PSGWQD'=0)
- SET ^PSI(58.5,"AMIS",$HOROLOG,PSGWADT,PSGWCAT,PSGWAOU,PSGWDN,PSGWQD)=""
- +5 SET ^(PSGDR)=$PIECE(^PSI(58.19,"AINV",PSGWIDA,PSGWDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR),"^",1,3)_"^"_PSGX(5)
- +6 IF $PIECE(PSGWSITE,"^",5)
- SET DIC(0)=""
- +7 IF '$TEST
- SET DIC(0)="QL"
- SET DLAYGO="^PSI(58.3,"
- +8 SET DIC="^PSI(58.3,"
- SET X="`"_PSGWDN
- DO ^DIC
- IF Y'<0
- SET PSGWDIN=+Y
- DO ^PSGWFLBO
- +9 ;
- EXP IF $PIECE(^PSI(58.1,PSGWDA,0),"^",4)
- SET DA(1)=PSGWDA
- SET DA=PSGDDA
- SET DIE="^PSI(58.1,"_DA(1)_",1,"
- SET DR=35
- DO ^DIE
- KILL DIE,DIC
- +1 GOTO PSGDR
- RESET ; Reset Sort key if AOUs taken out of order
- +1 IF $ORDER(PSGW("PO",PSGSORTK,0))'=PSGWAOU
- FOR J=0:0
- SET J=$ORDER(PSGW("PO",J))
- if 'J
- QUIT
- IF $ORDER(PSGW("PO",J,0))=PSGWAOU
- SET PSGSORTK=J
- QUIT
- +2 QUIT
