- PSGWPI1 ;BHAM ISC/MPH,CML-Print AOU Inventory Sheet - CONTINUED ; 18 Jun 93 / 10:40 AM
- ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
- EN1 ; PSGWIDA = DA of inventory being edited
- K PSGW("PO") S PSGPAGE=1,Y=DT X ^DD("DD") S PSGTODAY=Y,LNCNT=0
- I $D(BARFLG) F J=0,1 S @("PSGWBAR"_J)="" I $D(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_J)) S @("PSGWBAR"_J)=^("BAR"_J)
- I $D(BARFLG) S PSGWBARS=PSGWBAR1]""&(PSGWBAR0]"")
- I $D(AOU) S PSGW("PO",100,AOU)="" G START ; Check for single AOU print
- F SK=0:0 S SK=$O(^PSI(58.19,PSGWIDA,1,"C",SK)) Q:SK'>0 F J=0:0 S J=$O(^PSI(58.19,PSGWIDA,1,"C",SK,J)) Q:J'>0 S PSGW("PO",SK,J)=""
- START S PSGWIN=$P(^PSI(58.19,PSGWIDA,0),"^",1)
- WLOOP F PSGSORTK=0:0 S PSGSORTK=$O(PSGW("PO",PSGSORTK)) Q:PSGSORTK'>0 F PSGDA=0:0 S PSGDA=$O(PSGW("PO",PSGSORTK,PSGDA)) Q:PSGDA'>0 D SIN,WENT
- END W:$D(STKCHG) !!,"* Indicates change in stock level"
- I $E(IOST)'="C" W @IOF
- Q
- ;
- SIN ;Sort the ward item list
- K ^PSI(58.19,"AINV",PSGWIDA,PSGDA) S (PSGNT,J)=0,PSGTN="" F I=0:0 S I=$O(^PSI(58.19,PSGWIDA,1,PSGDA,1,I)) Q:I'>0 S PSGTN=PSGTN_I_",",PSGNT=PSGNT+1
- SINL S J=$O(^PSI(58.1,PSGDA,1,J)) Q:J'>0 S K=^(J,0)
- F I=1:1:PSGNT I $S($D(^PSI(58.1,PSGDA,1,J,2,$P(PSGTN,",",I))):1,$D(^PSI(58.16,$P(PSGTN,",",I),0)):$P(^(0),"^")="ALL",1:0) D CHKINA G:$T SINL
- G SINL
- ;
- CHKINA I $S('$D(^PSI(58.1,PSGDA,1,J,"I")):1,$O(^("I",PSGWDT))>0:1,$P(^PSI(58.1,PSGDA,1,J,0),"^",10)="Y":1,1:0) D LOC S ^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR)=+J_"^"_$P(K,"^",1,2)
- Q
- ;
- LOC ;Build item address
- S K1=$P(K,"^",8) F NN=1:1:3 S @("PSG"_NN)=$S($P(K1,",",NN)]"":$P(K1,",",NN),1:" ")
- S PSGDR=$S($D(^PSDRUG(+K,0))#2:$P(^(0),"^",1),1:+K)
- S PSGTYP=$S($D(^PSI(58.16,$P(PSGTN,",",I),0)):$P(^(0),"^"),1:"TYPE HAS BEEN DELETED")
- I '$D(^PSI(58.1,PSGDA,1,J,1,PSGWIDA,0)) D EN2^PSGWPI2
- Q
- ;
- WENT S PSG1="" I $D(^PSI(58.19,"AINV",PSGWIDA,PSGDA)) D EN1^PSGWPI2
- PSG1 S PSG1=$O(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1)) Q:PSG1="" W !,?17,PSG1 S PSG2="",EXP=$O(^PSI(58.17,"B",PSG1,0)) W:EXP>0 " ",$P(^PSI(58.17,EXP,0),"^",3) S LNCNT=LNCNT+1
- PSG2 S PSG2=$O(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2)) G PSG1:PSG2="" S PSG3=""
- PSG3 S PSG3=$O(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3)) G PSG2:PSG3="" S PSGTYP="" W !,?1,PSG2,$S(PSG3'=" ":","_PSG3,PSG3="":" ",1:"") S LNCNT=LNCNT+1
- PSGTYP I $D(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,"ALL")) S TYPE="" F Q=0:0 S TYPE=$O(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,TYPE)) Q:TYPE="" I TYPE'="ALL" K ^(TYPE)
- S PSGTYP=$O(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,PSGTYP)) G PSG3:PSGTYP="" S PSGDR="" S LFC=$S($X>7:"!?7",1:"?7") W:PSGTYP'="ALL" @LFC,PSGTYP
- PSGDR S PSGDR=$O(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR)) G PSGTYP:PSGDR="" S PSGDDA=+^(PSGDR),DRGDA=+$P(^(PSGDR),"^",2),STLEV=$P(^(PSGDR),"^",3),LOC=^PSI(58.1,PSGDA,1,PSGDDA,0)
- I $D(BARFLG) D:LNCNT>45 EN1^PSGWPI2 D BARWRT^PSGWPI2 G PSGDR
- D:$Y+5>IOSL EN1^PSGWPI2
- PNT W !,?10,PSGDR I $P(LOC,"^",5)="Y" W ?50,"*" S STKCHG="Y" S $P(^PSI(58.1,PSGDA,1,PSGDDA,0),"^",5)=""
- I (($P(LOC,"^",3)'>PSGWDT)&($P(LOC,"^",10)="Y")) W ?50,"*" S PSGINAD="Y" S $P(^PSI(58.1,PSGDA,1,PSGDDA,0),"^",10)=""
- W ?51,$J(STLEV,3)
- QCODE F MH=0:0 S MH=$O(^PSDRUG($P(^PSI(58.1,PSGDA,1,PSGDDA,0),"^",1),1,MH)) Q:MH'>0 I $P(^(MH,0),"^",3) W ?58,$E($P(^(0),"^",1),1,8) Q
- W ?66,"_____"
- I $P(PSGWSITE,"^",5) W ?75,$S($P(LOC,"^",11)]"":$J($P(LOC,"^",11),5),1:" "),?86,$S(+$P(LOC,"^",12):$J($P(LOC,"^",12),5),1:" "),?98,"______"
- I $P(PSGWSITE,"^",6) S TAB1=$S($P(PSGWSITE,"^",5):109,1:74),TAB2=$S($P(PSGWSITE,"^",5):118,1:82) W ?TAB1,"______",?TAB2,"E O D C"
- I $D(^PSI(58.1,PSGDA,1,PSGDDA,"EXP")) S Y=^("EXP") I Y X ^DD("DD") W !?14,"Expiration Date: ",Y
- I $D(PSGINAD) W !?14,"*Inactivated item, pull existing stock" K PSGINAD
- G PSGDR
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWPI1 3804 printed Dec 13, 2024@01:39:51 Page 2
- PSGWPI1 ;BHAM ISC/MPH,CML-Print AOU Inventory Sheet - CONTINUED ; 18 Jun 93 / 10:40 AM
- +1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
- EN1 ; PSGWIDA = DA of inventory being edited
- +1 KILL PSGW("PO")
- SET PSGPAGE=1
- SET Y=DT
- XECUTE ^DD("DD")
- SET PSGTODAY=Y
- SET LNCNT=0
- +2 IF $DATA(BARFLG)
- FOR J=0,1
- SET @("PSGWBAR"_J)=""
- IF $DATA(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_J))
- SET @("PSGWBAR"_J)=^("BAR"_J)
- +3 IF $DATA(BARFLG)
- SET PSGWBARS=PSGWBAR1]""&(PSGWBAR0]"")
- +4 ; Check for single AOU print
- IF $DATA(AOU)
- SET PSGW("PO",100,AOU)=""
- GOTO START
- +5 FOR SK=0:0
- SET SK=$ORDER(^PSI(58.19,PSGWIDA,1,"C",SK))
- if SK'>0
- QUIT
- FOR J=0:0
- SET J=$ORDER(^PSI(58.19,PSGWIDA,1,"C",SK,J))
- if J'>0
- QUIT
- SET PSGW("PO",SK,J)=""
- START SET PSGWIN=$PIECE(^PSI(58.19,PSGWIDA,0),"^",1)
- WLOOP FOR PSGSORTK=0:0
- SET PSGSORTK=$ORDER(PSGW("PO",PSGSORTK))
- if PSGSORTK'>0
- QUIT
- FOR PSGDA=0:0
- SET PSGDA=$ORDER(PSGW("PO",PSGSORTK,PSGDA))
- if PSGDA'>0
- QUIT
- DO SIN
- DO WENT
- END if $DATA(STKCHG)
- WRITE !!,"* Indicates change in stock level"
- +1 IF $EXTRACT(IOST)'="C"
- WRITE @IOF
- +2 QUIT
- +3 ;
- SIN ;Sort the ward item list
- +1 KILL ^PSI(58.19,"AINV",PSGWIDA,PSGDA)
- SET (PSGNT,J)=0
- SET PSGTN=""
- FOR I=0:0
- SET I=$ORDER(^PSI(58.19,PSGWIDA,1,PSGDA,1,I))
- if I'>0
- QUIT
- SET PSGTN=PSGTN_I_","
- SET PSGNT=PSGNT+1
- SINL SET J=$ORDER(^PSI(58.1,PSGDA,1,J))
- if J'>0
- QUIT
- SET K=^(J,0)
- +1 FOR I=1:1:PSGNT
- IF $SELECT($DATA(^PSI(58.1,PSGDA,1,J,2,$PIECE(PSGTN,",",I))):1,$DATA(^PSI(58.16,$PIECE(PSGTN,",",I),0)):$PIECE(^(0),"^")="ALL",1:0)
- DO CHKINA
- if $TEST
- GOTO SINL
- +2 GOTO SINL
- +3 ;
- CHKINA IF $SELECT('$DATA(^PSI(58.1,PSGDA,1,J,"I")):1,$ORDER(^("I",PSGWDT))>0:1,$PIECE(^PSI(58.1,PSGDA,1,J,0),"^",10)="Y":1,1:0)
- DO LOC
- SET ^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR)=+J_"^"_$PIECE(K,"^",1,2)
- +1 QUIT
- +2 ;
- LOC ;Build item address
- +1 SET K1=$PIECE(K,"^",8)
- FOR NN=1:1:3
- SET @("PSG"_NN)=$SELECT($PIECE(K1,",",NN)]"":$PIECE(K1,",",NN),1:" ")
- +2 SET PSGDR=$SELECT($DATA(^PSDRUG(+K,0))#2:$PIECE(^(0),"^",1),1:+K)
- +3 SET PSGTYP=$SELECT($DATA(^PSI(58.16,$PIECE(PSGTN,",",I),0)):$PIECE(^(0),"^"),1:"TYPE HAS BEEN DELETED")
- +4 IF '$DATA(^PSI(58.1,PSGDA,1,J,1,PSGWIDA,0))
- DO EN2^PSGWPI2
- +5 QUIT
- +6 ;
- WENT SET PSG1=""
- IF $DATA(^PSI(58.19,"AINV",PSGWIDA,PSGDA))
- DO EN1^PSGWPI2
- PSG1 SET PSG1=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1))
- if PSG1=""
- QUIT
- WRITE !,?17,PSG1
- SET PSG2=""
- SET EXP=$ORDER(^PSI(58.17,"B",PSG1,0))
- if EXP>0
- WRITE " ",$PIECE(^PSI(58.17,EXP,0),"^",3)
- SET LNCNT=LNCNT+1
- PSG2 SET PSG2=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2))
- if PSG2=""
- GOTO PSG1
- SET PSG3=""
- PSG3 SET PSG3=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3))
- if PSG3=""
- GOTO PSG2
- SET PSGTYP=""
- WRITE !,?1,PSG2,$SELECT(PSG3'=" ":","_PSG3,PSG3="":" ",1:"")
- SET LNCNT=LNCNT+1
- PSGTYP IF $DATA(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,"ALL"))
- SET TYPE=""
- FOR Q=0:0
- SET TYPE=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,TYPE))
- if TYPE=""
- QUIT
- IF TYPE'="ALL"
- KILL ^(TYPE)
- +1 SET PSGTYP=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,PSGTYP))
- if PSGTYP=""
- GOTO PSG3
- SET PSGDR=""
- SET LFC=$SELECT($X>7:"!?7",1:"?7")
- if PSGTYP'="ALL"
- WRITE @LFC,PSGTYP
- PSGDR SET PSGDR=$ORDER(^PSI(58.19,"AINV",PSGWIDA,PSGDA,PSG1,PSG2,PSG3,PSGTYP,PSGDR))
- if PSGDR=""
- GOTO PSGTYP
- SET PSGDDA=+^(PSGDR)
- SET DRGDA=+$PIECE(^(PSGDR),"^",2)
- SET STLEV=$PIECE(^(PSGDR),"^",3)
- SET LOC=^PSI(58.1,PSGDA,1,PSGDDA,0)
- +1 IF $DATA(BARFLG)
- if LNCNT>45
- DO EN1^PSGWPI2
- DO BARWRT^PSGWPI2
- GOTO PSGDR
- +2 if $Y+5>IOSL
- DO EN1^PSGWPI2
- PNT WRITE !,?10,PSGDR
- IF $PIECE(LOC,"^",5)="Y"
- WRITE ?50,"*"
- SET STKCHG="Y"
- SET $PIECE(^PSI(58.1,PSGDA,1,PSGDDA,0),"^",5)=""
- +1 IF (($PIECE(LOC,"^",3)'>PSGWDT)&($PIECE(LOC,"^",10)="Y"))
- WRITE ?50,"*"
- SET PSGINAD="Y"
- SET $PIECE(^PSI(58.1,PSGDA,1,PSGDDA,0),"^",10)=""
- +2 WRITE ?51,$JUSTIFY(STLEV,3)
- QCODE FOR MH=0:0
- SET MH=$ORDER(^PSDRUG($PIECE(^PSI(58.1,PSGDA,1,PSGDDA,0),"^",1),1,MH))
- if MH'>0
- QUIT
- IF $PIECE(^(MH,0),"^",3)
- WRITE ?58,$EXTRACT($PIECE(^(0),"^",1),1,8)
- QUIT
- +1 WRITE ?66,"_____"
- +2 IF $PIECE(PSGWSITE,"^",5)
- WRITE ?75,$SELECT($PIECE(LOC,"^",11)]"":$JUSTIFY($PIECE(LOC,"^",11),5),1:" "),?86,$SELECT(+$PIECE(LOC,"^",12):$JUSTIFY($PIECE(LOC,"^",12),5),1:" "),?98,"______"
- +3 IF $PIECE(PSGWSITE,"^",6)
- SET TAB1=$SELECT($PIECE(PSGWSITE,"^",5):109,1:74)
- SET TAB2=$SELECT($PIECE(PSGWSITE,"^",5):118,1:82)
- WRITE ?TAB1,"______",?TAB2,"E O D C"
- +4 IF $DATA(^PSI(58.1,PSGDA,1,PSGDDA,"EXP"))
- SET Y=^("EXP")
- IF Y
- XECUTE ^DD("DD")
- WRITE !?14,"Expiration Date: ",Y
- +5 IF $DATA(PSGINAD)
- WRITE !?14,"*Inactivated item, pull existing stock"
- KILL PSGINAD
- +6 GOTO PSGDR