- 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
- 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
