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 Dec 13, 2024@01:39:11 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
