- PSGWDR ;BHAM ISC/PTD,CML-Returns Breakdown Report for Selected Date Range ; 30 Aug 93 / 10:49 AM
- ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
- BDT S %DT="AEX",%DT("A")="BEGINNING date for report: " D ^%DT K %DT G:Y<0 END S BDT=Y
- EDT S %DT="AEX",%DT(0)=BDT,%DT("A")="ENDING date for report: " D ^%DT K %DT G:Y<0 END S EDT=Y
- D SEL^PSGWUTL1 G:'$D(SEL) END G:SEL="I" EN
- ASKAOU F JJ=0:0 S DIC="^PSI(58.1,",DIC(0)="QEAM" D ^DIC K DIC Q:Y<0 S AOULP(+Y)=""
- I '$D(AOULP)&(X'="^ALL") G END
- I X="^ALL" F AOU=0:0 S AOU=$O(^PSI(58.1,AOU)) Q:'AOU S AOULP(AOU)=""
- EN G:'$D(AOULP) END W !!,"The right margin for this report is 80.",!,"You may queue the report to print at a later time.",!!
- DEV K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED!" G END
- I $D(IO("Q")) K IO("Q") S ZTRTN="ENQ^PSGWDR",ZTDESC="Print Returns Analysis" S:$D(AOULP) ZTSAVE("AOULP(")="" F G="BDT","EDT","ALL","SEL","IGDA" S:$D(@G) ZTSAVE(G)=""
- I D ^%ZTLOAD,HOME^%ZIS K ZTSK G END
- U IO
- ;
- ENQ ;ENTRY POINT WHEN QUEUED
- K ^TMP("PSGWRET",$J) S PGCT=1,AOU=""
- AOU S AOU=$O(AOULP(AOU)) G:'AOU PRINT
- DRUG ;LOOP THROUGH DRUGS FOR AOU
- S DRGDA=0
- DRGLP S DRGDA=$O(^PSI(58.1,AOU,1,DRGDA)) G:'DRGDA AOU S DRGNM=$P(^PSI(58.1,AOU,1,DRGDA,0),"^")
- I '$O(^PSDRUG(DRGNM,0)) S DIK="^PSI(58.1,"_AOU_",1,",DA=DRGDA,DA(1)=AOU D ^DIK K DIK G DRGLP
- S DRGNAME=$P(^PSDRUG(DRGNM,0),"^")
- ;
- RET ;RETURNS
- S RETDT=0
- RETLP S RETDT=$O(^PSI(58.1,AOU,1,DRGDA,3,RETDT)) G:'RETDT DRGLP I (RETDT'<BDT)&(RETDT'>EDT) D SET
- G RETLP
- ;
- PRINT ;
- S AOU=0,QFLG="" I '$O(^TMP("PSGWRET",$J,0)) D HDR W !,"NO RETURNS FOR SELECTED DATE RANGE." G DONE
- AOULP S AOU=$O(^TMP("PSGWRET",$J,AOU)) G:'AOU DONE I PGCT>1 D PRTCHK G:QFLG END
- D:PGCT<2 HDR W !?5,"==> ",$P(^PSI(58.1,AOU,0),"^") S DRG=0 I $D(^PSI(58.1,AOU,"I")),^("I")]"",^("I")'>DT W " *** INACTIVE ***"
- DRLP S DRG=$O(^TMP("PSGWRET",$J,AOU,DRG)),RET=0 G:DRG="" AOULP D:$Y+5>IOSL PRTCHK G:QFLG END W !!,"----------",!,DRG
- RLP S RET=$O(^TMP("PSGWRET",$J,AOU,DRG,RET)) G:'RET DRLP S LOCR=^TMP("PSGWRET",$J,AOU,DRG,RET),LOCQD=$P(LOCR,"^"),LOCRSN=$P(LOCR,"^",2),Y=RET X ^DD("DD") S RETPRT=Y
- S:LOCRSN]"" CNT=$L(LOCRSN,";;") I LOCRSN="" S LOCRSN=";;",CNT=1
- D:$Y+5>IOSL PRTCHK G:QFLG END W !?35,RETPRT,?51,$J(LOCQD,4) S RSN=$P(LOCRSN,";;",2) D RSN W ?65,RSN
- I CNT>2 F LL=3:1:CNT S RSN=$P(LOCRSN,";;",LL) D RSN D:$Y+5>IOSL PRTCHK W !?65,RSN
- G RLP
- ;
- DONE I $E(IOST)'="C" W @IOF
- I $E(IOST)="C" D:'QFLG SS^PSGWUTL1
- END K ZTSK,^TMP("PSGWRET",$J),AOU,AOULP,ANS,CNT,QFLG,JJ,LL,ALL,BDT,DRG,DRGDA,DRGNAME,DRGNM,EDT,J,LOC,LOCQD,LOCR,LOCRSN,SEL,IGDA,RET,RSN,PGCT,QD,RETDT,RETPRT,%,%I,%H,DA,G,X,Y,IO("Q") D ^%ZISC
- S:$D(ZTQUEUED) ZTREQ="@" Q
- ;
- HDR ;PRINT REPORT HEADER
- W:$Y @IOF W !,"RETURNS BREAKDOWN REPORT FROM " S Y=BDT X ^DD("DD") W Y," TO " S Y=EDT X ^DD("DD") W Y,?70,"PAGE ",PGCT I $D(SEL),SEL="I",$D(IGDA) W !,"FOR INVENTORY GROUP - ",$P(^PSI(58.2,IGDA,0),"^")
- W !!?5,"AREA OF USE" W ?55,"DATE: ",$$PSGWDT^PSGWUTL1,!
- W !?37,"RETURN",?50,"QUANTITY",?65,"RETURN",!?14,"ITEM",?38,"DATE",?50,"RETURNED",?65,"REASON",! S PGCT=PGCT+1 F J=1:1:80 W "-"
- Q
- SET ;
- S QD=$P(^PSI(58.1,AOU,1,DRGDA,3,RETDT,0),"^",2),RSN="" F LL=0:0 S LL=$O(^PSI(58.1,AOU,1,DRGDA,3,RETDT,1,LL)) Q:'LL I ^PSI(58.1,AOU,1,DRGDA,3,RETDT,1,LL,0)]"" S RSN=RSN_";;"_^(0)
- S:QD'<1 ^TMP("PSGWRET",$J,AOU,DRGNAME,RETDT)=QD_"^"_RSN Q
- RSN S RSN=$S(RSN="E":"EXPIRED",RSN="O":"OVER STOCK",RSN="D":"DEL FR STOCK",RSN="C":"CHG STOCK LEV",1:"NOT LISTED") Q
- PRTCHK ;
- I $E(IOST)="C" W !!,"Press <RETURN> to Continue or ""^"" to Exit: " R ANS:DTIME S:'$T ANS="^" D:ANS?1."?" HELP^PSGWUTL1 I ANS="^" S QFLG=1 Q
- D HDR Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWDR 3655 printed Feb 18, 2025@23:05:35 Page 2
- PSGWDR ;BHAM ISC/PTD,CML-Returns Breakdown Report for Selected Date Range ; 30 Aug 93 / 10:49 AM
- +1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
- BDT SET %DT="AEX"
- SET %DT("A")="BEGINNING date for report: "
- DO ^%DT
- KILL %DT
- if Y<0
- GOTO END
- SET BDT=Y
- EDT SET %DT="AEX"
- SET %DT(0)=BDT
- SET %DT("A")="ENDING date for report: "
- DO ^%DT
- KILL %DT
- if Y<0
- GOTO END
- SET EDT=Y
- +1 DO SEL^PSGWUTL1
- if '$DATA(SEL)
- GOTO END
- if SEL="I"
- GOTO EN
- ASKAOU FOR JJ=0:0
- SET DIC="^PSI(58.1,"
- SET DIC(0)="QEAM"
- DO ^DIC
- KILL DIC
- if Y<0
- QUIT
- SET AOULP(+Y)=""
- +1 IF '$DATA(AOULP)&(X'="^ALL")
- GOTO END
- +2 IF X="^ALL"
- FOR AOU=0:0
- SET AOU=$ORDER(^PSI(58.1,AOU))
- if 'AOU
- QUIT
- SET AOULP(AOU)=""
- EN if '$DATA(AOULP)
- GOTO END
- WRITE !!,"The right margin for this report is 80.",!,"You may queue the report to print at a later time.",!!
- DEV KILL %ZIS,IOP
- SET %ZIS="QM"
- SET %ZIS("B")=""
- DO ^%ZIS
- IF POP
- WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED!"
- GOTO END
- +1 IF $DATA(IO("Q"))
- KILL IO("Q")
- SET ZTRTN="ENQ^PSGWDR"
- SET ZTDESC="Print Returns Analysis"
- if $DATA(AOULP)
- SET ZTSAVE("AOULP(")=""
- FOR G="BDT","EDT","ALL","SEL","IGDA"
- if $DATA(@G)
- SET ZTSAVE(G)=""
- +2 IF $TEST
- DO ^%ZTLOAD
- DO HOME^%ZIS
- KILL ZTSK
- GOTO END
- +3 USE IO
- +4 ;
- ENQ ;ENTRY POINT WHEN QUEUED
- +1 KILL ^TMP("PSGWRET",$JOB)
- SET PGCT=1
- SET AOU=""
- AOU SET AOU=$ORDER(AOULP(AOU))
- if 'AOU
- GOTO PRINT
- DRUG ;LOOP THROUGH DRUGS FOR AOU
- +1 SET DRGDA=0
- DRGLP SET DRGDA=$ORDER(^PSI(58.1,AOU,1,DRGDA))
- if 'DRGDA
- GOTO AOU
- SET DRGNM=$PIECE(^PSI(58.1,AOU,1,DRGDA,0),"^")
- +1 IF '$ORDER(^PSDRUG(DRGNM,0))
- SET DIK="^PSI(58.1,"_AOU_",1,"
- SET DA=DRGDA
- SET DA(1)=AOU
- DO ^DIK
- KILL DIK
- GOTO DRGLP
- +2 SET DRGNAME=$PIECE(^PSDRUG(DRGNM,0),"^")
- +3 ;
- RET ;RETURNS
- +1 SET RETDT=0
- RETLP SET RETDT=$ORDER(^PSI(58.1,AOU,1,DRGDA,3,RETDT))
- if 'RETDT
- GOTO DRGLP
- IF (RETDT'<BDT)&(RETDT'>EDT)
- DO SET
- +1 GOTO RETLP
- +2 ;
- PRINT ;
- +1 SET AOU=0
- SET QFLG=""
- IF '$ORDER(^TMP("PSGWRET",$JOB,0))
- DO HDR
- WRITE !,"NO RETURNS FOR SELECTED DATE RANGE."
- GOTO DONE
- AOULP SET AOU=$ORDER(^TMP("PSGWRET",$JOB,AOU))
- if 'AOU
- GOTO DONE
- IF PGCT>1
- DO PRTCHK
- if QFLG
- GOTO END
- +1 if PGCT<2
- DO HDR
- WRITE !?5,"==> ",$PIECE(^PSI(58.1,AOU,0),"^")
- SET DRG=0
- IF $DATA(^PSI(58.1,AOU,"I"))
- IF ^("I")]""
- IF ^("I")'>DT
- WRITE " *** INACTIVE ***"
- DRLP SET DRG=$ORDER(^TMP("PSGWRET",$JOB,AOU,DRG))
- SET RET=0
- if DRG=""
- GOTO AOULP
- if $Y+5>IOSL
- DO PRTCHK
- if QFLG
- GOTO END
- WRITE !!,"----------",!,DRG
- RLP SET RET=$ORDER(^TMP("PSGWRET",$JOB,AOU,DRG,RET))
- if 'RET
- GOTO DRLP
- SET LOCR=^TMP("PSGWRET",$JOB,AOU,DRG,RET)
- SET LOCQD=$PIECE(LOCR,"^")
- SET LOCRSN=$PIECE(LOCR,"^",2)
- SET Y=RET
- XECUTE ^DD("DD")
- SET RETPRT=Y
- +1 if LOCRSN]""
- SET CNT=$LENGTH(LOCRSN,";;")
- IF LOCRSN=""
- SET LOCRSN=";;"
- SET CNT=1
- +2 if $Y+5>IOSL
- DO PRTCHK
- if QFLG
- GOTO END
- WRITE !?35,RETPRT,?51,$JUSTIFY(LOCQD,4)
- SET RSN=$PIECE(LOCRSN,";;",2)
- DO RSN
- WRITE ?65,RSN
- +3 IF CNT>2
- FOR LL=3:1:CNT
- SET RSN=$PIECE(LOCRSN,";;",LL)
- DO RSN
- if $Y+5>IOSL
- DO PRTCHK
- WRITE !?65,RSN
- +4 GOTO RLP
- +5 ;
- DONE IF $EXTRACT(IOST)'="C"
- WRITE @IOF
- +1 IF $EXTRACT(IOST)="C"
- if 'QFLG
- DO SS^PSGWUTL1
- END KILL ZTSK,^TMP("PSGWRET",$JOB),AOU,AOULP,ANS,CNT,QFLG,JJ,LL,ALL,BDT,DRG,DRGDA,DRGNAME,DRGNM,EDT,J,LOC,LOCQD,LOCR,LOCRSN,SEL,IGDA,RET,RSN,PGCT,QD,RETDT,RETPRT,%,%I,%H,DA,G,X,Y,IO("Q")
- DO ^%ZISC
- +1 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- +2 ;
- HDR ;PRINT REPORT HEADER
- +1 if $Y
- WRITE @IOF
- WRITE !,"RETURNS BREAKDOWN REPORT FROM "
- SET Y=BDT
- XECUTE ^DD("DD")
- WRITE Y," TO "
- SET Y=EDT
- XECUTE ^DD("DD")
- WRITE Y,?70,"PAGE ",PGCT
- IF $DATA(SEL)
- IF SEL="I"
- IF $DATA(IGDA)
- WRITE !,"FOR INVENTORY GROUP - ",$PIECE(^PSI(58.2,IGDA,0),"^")
- +2 WRITE !!?5,"AREA OF USE"
- WRITE ?55,"DATE: ",$$PSGWDT^PSGWUTL1,!
- +3 WRITE !?37,"RETURN",?50,"QUANTITY",?65,"RETURN",!?14,"ITEM",?38,"DATE",?50,"RETURNED",?65,"REASON",!
- SET PGCT=PGCT+1
- FOR J=1:1:80
- WRITE "-"
- +4 QUIT
- SET ;
- +1 SET QD=$PIECE(^PSI(58.1,AOU,1,DRGDA,3,RETDT,0),"^",2)
- SET RSN=""
- FOR LL=0:0
- SET LL=$ORDER(^PSI(58.1,AOU,1,DRGDA,3,RETDT,1,LL))
- if 'LL
- QUIT
- IF ^PSI(58.1,AOU,1,DRGDA,3,RETDT,1,LL,0)]""
- SET RSN=RSN_";;"_^(0)
- +2 if QD'<1
- SET ^TMP("PSGWRET",$JOB,AOU,DRGNAME,RETDT)=QD_"^"_RSN
- QUIT
- RSN SET RSN=$SELECT(RSN="E":"EXPIRED",RSN="O":"OVER STOCK",RSN="D":"DEL FR STOCK",RSN="C":"CHG STOCK LEV",1:"NOT LISTED")
- QUIT
- PRTCHK ;
- +1 IF $EXTRACT(IOST)="C"
- WRITE !!,"Press <RETURN> to Continue or ""^"" to Exit: "
- READ ANS:DTIME
- if '$TEST
- SET ANS="^"
- if ANS?1."?"
- DO HELP^PSGWUTL1
- IF ANS="^"
- SET QFLG=1
- QUIT
- +2 DO HDR
- QUIT