PSALOG2 ;BIR/LTL-Post Drug Procurement History ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15**; 10/24/97
;This routine compiles a report of warehouse drugs.
;
;References to $$DESCR^PRCPUX1 are covered by IA #259
;References to $$INVNAME^PRCPUX1 are covered by IA #259
;References to ^PRC( are covered by IA #214
;References to ^PRCS( are covered by IA #198
;References to ^PRCP( are covered by IA #214
;
N PSA,PSAB,PSAC,PSAION,PSAOUT,X,X2,X3,Y,PSAPG,DIR,DIRUT,DTOUT,DUOUT,%DT,PSALN
S %DT="AEP",%DT("A")="Please select month: ",%DT("B")="T-1M"
D ^%DT S PSA(11)=$E(Y,1,5),PSA(12)=$E(PSA(11),4,5),PSAOUT=0
I Y<0 S PSAOUT=1 G END
X ^DD("DD") S PSA(13)=$E(Y,1,3)_" '"_$E(PSA(11),2,3)
K IO("Q") N %ZIS,IOP,POP S %ZIS="Q" W ! D ^%ZIS S PSAION=$G(ION)
I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED!" S PSAOUT=1 G END
I $D(IO("Q")) N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK S ZTRTN="GO^PSALOG2",ZTDESC="Monthly warehoused drug report",ZTSAVE("PSA*")="" D ^%ZTLOAD,HOME^%ZIS S PSAOUT=1 G END
GO S PSA=$O(^PRCP(445,"AC","W","")),(PSA(1),PSAPG)=0 D HEADER
F S PSA(1)=$O(^PRCP(445,+PSA,1,PSA(1))) Q:'PSA(1) I $P($G(^PRC(441,+PSA(1),0)),U,3)=6505 W:$E($G(IOST))="C" "." S ^TMP("PSA",$J,$P($G(^PRC(441,+PSA(1),0)),U,2))=$G(^(0))
S PSA(2)=0
F S PSA(2)=$O(^TMP("PSA",$J,PSA(2))) Q:PSA(2)']"" S PSA(3)=$P($G(^TMP("PSA",$J,PSA(2))),U) D:$O(^PRCP(445.2,"AD",PSA,PSA(3),""))
.S PSA(4)=0
.F S PSA(4)=$O(^PRCP(445.2,"AD",+PSA,PSA(3),PSA(4))) Q:'PSA(4) D:$P($G(^PRCP(445.2,+PSA(4),0)),U,4)?1"R"&($E($P($G(^(0)),U,17),1,5)=PSA(11))
..S ^TMP("PSAB",$J,$P($G(^PRCP(445.2,+PSA(4),0)),U,18),$P($G(^(0)),U,5),PSA(4))=$G(^(0))
S (PSA(4),PSAB,PSAB(1))=0
F PSAC=0:1 S PSAB=$O(^TMP("PSAB",$J,PSAB)) Q:'PSAB D:PSAC HEADER G:PSAOUT END W !!,"PRIMARY INVENTORY: ",$$INVNAME^PRCPUX1(PSAB) F S PSA(4)=$O(^TMP("PSAB",$J,PSAB,PSA(4))) Q:'PSA(4)!(PSAOUT) D G:PSAOUT END
.W !!,"ITEM #: ",PSA(4),?15,$$DESCR^PRCPUX1(PSAB,PSA(4)),!!,"QTY",?9,"QTY",?19,"PKG",?29,"UNIT",?40,"TOTAL",?51,"DATE",?61,"TRANSACTION",!,"ORD",?9,"REC",?29,"COST",?40,"COST"
.F S PSAB(1)=$O(^TMP("PSAB",$J,+PSAB,+PSA(4),PSAB(1))) Q:'PSAB(1)!(PSAOUT) S PSA(5)=$G(^TMP("PSAB",$J,+PSAB,+PSA(4),+PSAB(1))) D D:$Y+6>IOSL HEADER Q:PSAOUT
..Q:'$P(PSA(5),U,19)
..S PSA(22)=0,PSA(33)=$O(^PRCS(410,"B",$P(PSA(5),U,19),""))
..F S PSA(22)=$O(^PRCS(410,+PSA(33),"IT",PSA(22))) Q:'PSA(22) S:$P($G(^PRCS(410,+PSA(33),"IT",PSA(22),0)),U,5)=PSA(4) PSA(44)=$P($G(^(0)),U,2)
..W !!,$J($G(PSA(44)),3)
..S PSA(99)=$G(PSA(99))+PSA(44) K PSA(44)
..S PSA(8)=-$P(PSA(5),U,7),PSA(9)=$G(PSA(9))+PSA(8) W ?9,$J(PSA(8),3)
..W ?18,$P(PSA(5),U,6)
..S (X,PSA(7))=$P(PSA(5),U,9),X2="2$" D COMMA^%DTC W X
..S X=-$P(PSA(5),U,7)*PSA(7),X2="2$",PSA(10)=$G(PSA(10))+X D COMMA^%DTC W X
..S Y=$P($P(PSA(5),U,17),".") X ^DD("DD") W ?50,$S($L(Y)=11:$E(Y,1,6),$L(Y)=10:$E(Y,1,5),1:"UNKNOWN")
..W ?59,$P(PSA(5),U,19)
..I '$O(^TMP("PSAB",$J,+PSAB,+PSA(4),+PSAB(1))) W !,PSALN,!,$J(PSA(99),3),?9,$J(PSA(9),3) S X=$G(PSA(10)),X2="2$" D COMMA^%DTC W ?16,"<TOTALS>",?34,X S ^TMP("PSAC",$J,(999999999-PSA(10)),+PSA(4))=PSA(10)_U_PSAB K PSA(9),PSA(10),PSA(99)
I '$D(^TMP("PSAB",$J)) W !,"Sorry, no procurements for that month!",! S PSAOUT=1
I $D(ZTQUEUED),$D(^TMP("PSAB",$J)) S PSA(44)=500 D LOOP2^PSALOG3
END W:$E(IOST)'="C" @IOF
I $E(IOST,1,2)="C-",'$G(PSAOUT) W ! S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu." D ^DIR K DIR
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q")
K ^TMP("PSA",$J),^TMP("PSAB",$J) I $G(PSAOUT) K ^TMP("PSAC",$J) Q
S DIR(0)="Y",DIR("A")="Would you like a list of high dollar items",DIR("B")="Yes",DIR("?")="If yes, I'll let you pick a cut-off dollar amount and sort from high to low" W ! D ^DIR K DIR I 'Y S PSAOUT=1 G END
S DIR(0)="N",DIR("A")="Please enter the lowest amount you are interested in listing",DIR("B")=1000,DIR("?")="Enter the lowest dollar amount that you want included, without $" W ! D ^DIR K DIR S:Y PSA(44)=Y I 'Y S PSAOUT=1 G END
K IO("Q") N %ZIS,IOP,POP,X3 S %ZIS="Q",%ZIS("B")=$G(PSAION) W ! D ^%ZIS
I POP W !,"NO DEVICE SELECTED OR OUTPUT PRINTED!" S PSAOUT=1 G END
I $D(IO("Q")) N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK S ZTRTN="LOOP2^PSALOG3",ZTDESC="High Dollar Drug Report",ZTSAVE("^TMP(""PSAC"",$J,")="",ZTSAVE("PSA*")="",ZTSAVE("PSALN")="" D ^%ZTLOAD,HOME^%ZIS S PSAOUT=1 G END
D LOOP2^PSALOG3 G END
I $$S^%ZTLOAD W !!,"Task #",$G(ZTSK),", ",$G(ZTDESC)," was stopped by ",$P($G(^VA(200,+$G(DUZ),0)),U),"." S PSAOUT=1 Q
W:$Y @IOF S $P(PSALN,"-",81)="",PSAPG=PSAPG+1
W !,?2,"WAREHOUSE DRUG PROCUREMENTS FOR ",PSA(13),?70,"PAGE: ",PSAPG,!,PSALN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSALOG2 4719 printed Dec 13, 2024@01:49:39 Page 2
PSALOG2 ;BIR/LTL-Post Drug Procurement History ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15**; 10/24/97
+2 ;This routine compiles a report of warehouse drugs.
+3 ;
+4 ;References to $$DESCR^PRCPUX1 are covered by IA #259
+5 ;References to $$INVNAME^PRCPUX1 are covered by IA #259
+6 ;References to ^PRC( are covered by IA #214
+7 ;References to ^PRCS( are covered by IA #198
+8 ;References to ^PRCP( are covered by IA #214
+9 ;
+10 NEW PSA,PSAB,PSAC,PSAION,PSAOUT,X,X2,X3,Y,PSAPG,DIR,DIRUT,DTOUT,DUOUT,%DT,PSALN
+11 SET %DT="AEP"
SET %DT("A")="Please select month: "
SET %DT("B")="T-1M"
+12 DO ^%DT
SET PSA(11)=$EXTRACT(Y,1,5)
SET PSA(12)=$EXTRACT(PSA(11),4,5)
SET PSAOUT=0
+13 IF Y<0
SET PSAOUT=1
GOTO END
+14 XECUTE ^DD("DD")
SET PSA(13)=$EXTRACT(Y,1,3)_" '"_$EXTRACT(PSA(11),2,3)
+15 KILL IO("Q")
NEW %ZIS,IOP,POP
SET %ZIS="Q"
WRITE !
DO ^%ZIS
SET PSAION=$GET(ION)
+16 IF POP
WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED!"
SET PSAOUT=1
GOTO END
+17 IF $DATA(IO("Q"))
NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
SET ZTRTN="GO^PSALOG2"
SET ZTDESC="Monthly warehoused drug report"
SET ZTSAVE("PSA*")=""
DO ^%ZTLOAD
DO HOME^%ZIS
SET PSAOUT=1
GOTO END
GO SET PSA=$ORDER(^PRCP(445,"AC","W",""))
SET (PSA(1),PSAPG)=0
DO HEADER
+1 FOR
SET PSA(1)=$ORDER(^PRCP(445,+PSA,1,PSA(1)))
if 'PSA(1)
QUIT
IF $PIECE($GET(^PRC(441,+PSA(1),0)),U,3)=6505
if $EXTRACT($GET(IOST))="C"
WRITE "."
SET ^TMP("PSA",$JOB,$PIECE($GET(^PRC(441,+PSA(1),0)),U,2))=$GET(^(0))
+2 SET PSA(2)=0
+3 FOR
SET PSA(2)=$ORDER(^TMP("PSA",$JOB,PSA(2)))
if PSA(2)']""
QUIT
SET PSA(3)=$PIECE($GET(^TMP("PSA",$JOB,PSA(2))),U)
if $ORDER(^PRCP(445.2,"AD",PSA,PSA(3),""))
Begin DoDot:1
+4 SET PSA(4)=0
+5 FOR
SET PSA(4)=$ORDER(^PRCP(445.2,"AD",+PSA,PSA(3),PSA(4)))
if 'PSA(4)
QUIT
if $PIECE($GET(^PRCP(445.2,+PSA(4),0)),U,4)?1"R"&($EXTRACT($PIECE($GET(^(0)),U,17),1,5)=PSA(11))
Begin DoDot:2
+6 SET ^TMP("PSAB",$JOB,$PIECE($GET(^PRCP(445.2,+PSA(4),0)),U,18),$PIECE($GET(^(0)),U,5),PSA(4))=$GET(^(0))
End DoDot:2
End DoDot:1
+7 SET (PSA(4),PSAB,PSAB(1))=0
+8 FOR PSAC=0:1
SET PSAB=$ORDER(^TMP("PSAB",$JOB,PSAB))
if 'PSAB
QUIT
if PSAC
DO HEADER
if PSAOUT
GOTO END
WRITE !!,"PRIMARY INVENTORY: ",$$INVNAME^PRCPUX1(PSAB)
FOR
SET PSA(4)=$ORDER(^TMP("PSAB",$JOB,PSAB,PSA(4)))
if 'PSA(4)!(PSAOUT)
QUIT
Begin DoDot:1
+9 WRITE !!,"ITEM #: ",PSA(4),?15,$$DESCR^PRCPUX1(PSAB,PSA(4)),!!,"QTY",?9,"QTY",?19,"PKG",?29,"UNIT",?40,"TOTAL",?51,"DATE",?61,"TRANSACTION",!,"ORD",?9,"REC",?29,"COST",?40,"COST"
+10 FOR
SET PSAB(1)=$ORDER(^TMP("PSAB",$JOB,+PSAB,+PSA(4),PSAB(1)))
if 'PSAB(1)!(PSAOUT)
QUIT
SET PSA(5)=$GET(^TMP("PSAB",$JOB,+PSAB,+PSA(4),+PSAB(1)))
Begin DoDot:2
+11 if '$PIECE(PSA(5),U,19)
QUIT
+12 SET PSA(22)=0
SET PSA(33)=$ORDER(^PRCS(410,"B",$PIECE(PSA(5),U,19),""))
+13 FOR
SET PSA(22)=$ORDER(^PRCS(410,+PSA(33),"IT",PSA(22)))
if 'PSA(22)
QUIT
if $PIECE($GET(^PRCS(410,+PSA(33),"IT",PSA(22),0)),U,5)=PSA(4)
SET PSA(44)=$PIECE($GET(^(0)),U,2)
+14 WRITE !!,$JUSTIFY($GET(PSA(44)),3)
+15 SET PSA(99)=$GET(PSA(99))+PSA(44)
KILL PSA(44)
+16 SET PSA(8)=-$PIECE(PSA(5),U,7)
SET PSA(9)=$GET(PSA(9))+PSA(8)
WRITE ?9,$JUSTIFY(PSA(8),3)
+17 WRITE ?18,$PIECE(PSA(5),U,6)
+18 SET (X,PSA(7))=$PIECE(PSA(5),U,9)
SET X2="2$"
DO COMMA^%DTC
WRITE X
+19 SET X=-$PIECE(PSA(5),U,7)*PSA(7)
SET X2="2$"
SET PSA(10)=$GET(PSA(10))+X
DO COMMA^%DTC
WRITE X
+20 SET Y=$PIECE($PIECE(PSA(5),U,17),".")
XECUTE ^DD("DD")
WRITE ?50,$SELECT($LENGTH(Y)=11:$EXTRACT(Y,1,6),$LENGTH(Y)=10:$EXTRACT(Y,1,5),1:"UNKNOWN")
+21 WRITE ?59,$PIECE(PSA(5),U,19)
+22 IF '$ORDER(^TMP("PSAB",$JOB,+PSAB,+PSA(4),+PSAB(1)))
WRITE !,PSALN,!,$JUSTIFY(PSA(99),3),?9,$JUSTIFY(PSA(9),3)
SET X=$GET(PSA(10))
SET X2="2$"
DO COMMA^%DTC
WRITE ?16,"<TOTALS>",?34,X
SET ^TMP("PSAC",$JOB,(999999999-PSA(10)),+PSA(4))=PSA(10)_U_PSAB
KILL PSA(9),PSA(10),PSA(99)
End DoDot:2
if $Y+6>IOSL
DO HEADER
if PSAOUT
QUIT
End DoDot:1
if PSAOUT
GOTO END
+23 IF '$DATA(^TMP("PSAB",$JOB))
WRITE !,"Sorry, no procurements for that month!",!
SET PSAOUT=1
+24 IF $DATA(ZTQUEUED)
IF $DATA(^TMP("PSAB",$JOB))
SET PSA(44)=500
DO LOOP2^PSALOG3
END if $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST,1,2)="C-"
IF '$GET(PSAOUT)
WRITE !
SET DIR(0)="EA"
SET DIR("A")="END OF REPORT! Press <RET> to return to the menu."
DO ^DIR
KILL DIR
+2 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL IO("Q")
+3 KILL ^TMP("PSA",$JOB),^TMP("PSAB",$JOB)
IF $GET(PSAOUT)
KILL ^TMP("PSAC",$JOB)
QUIT
+4 SET DIR(0)="Y"
SET DIR("A")="Would you like a list of high dollar items"
SET DIR("B")="Yes"
SET DIR("?")="If yes, I'll let you pick a cut-off dollar amount and sort from high to low"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET PSAOUT=1
GOTO END
+5 SET DIR(0)="N"
SET DIR("A")="Please enter the lowest amount you are interested in listing"
SET DIR("B")=1000
SET DIR("?")="Enter the lowest dollar amount that you want included, without $"
WRITE !
DO ^DIR
KILL DIR
if Y
SET PSA(44)=Y
IF 'Y
SET PSAOUT=1
GOTO END
+6 KILL IO("Q")
NEW %ZIS,IOP,POP,X3
SET %ZIS="Q"
SET %ZIS("B")=$GET(PSAION)
WRITE !
DO ^%ZIS
+7 IF POP
WRITE !,"NO DEVICE SELECTED OR OUTPUT PRINTED!"
SET PSAOUT=1
GOTO END
+8 IF $DATA(IO("Q"))
NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
SET ZTRTN="LOOP2^PSALOG3"
SET ZTDESC="High Dollar Drug Report"
SET ZTSAVE("^TMP(""PSAC"",$J,")=""
SET ZTSAVE("PSA*")=""
SET ZTSAVE("PSALN")=""
DO ^%ZTLOAD
DO HOME^%ZIS
SET PSAOUT=1
GOTO END
+9 DO LOOP2^PSALOG3
GOTO END
IF PSAPG
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSAOUT=1
QUIT
+1 IF $$S^%ZTLOAD
WRITE !!,"Task #",$GET(ZTSK),", ",$GET(ZTDESC)," was stopped by ",$PIECE($GET(^VA(200,+$GET(DUZ),0)),U),"."
SET PSAOUT=1
QUIT
+2 if $Y
WRITE @IOF
SET $PIECE(PSALN,"-",81)=""
SET PSAPG=PSAPG+1
+3 WRITE !,?2,"WAREHOUSE DRUG PROCUREMENTS FOR ",PSA(13),?70,"PAGE: ",PSAPG,!,PSALN
+4 QUIT
