PRCPRPDH ;WISC/RFJ-distribution cost report (to or from primary) ;12 Feb 92
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
N %,COSTCNTR,CUMTOT,D,DA,DATA,DATE,END,ENDDT,INVPT,MAXDT,MISCOST,MISDA,MISINVPT,NEW,NOW,NOWDT,PAGE,PRCPFLAG,SCREEN,START,STARTDT,FROM,TOTAL,TYPE,X,Y
S DIR(0)="S^1:TO;2:FROM;",DIR("A")="Print distributions TO or FROM inventory point",DIR("B")="FROM" D ^DIR K DIR S TYPE=$S($G(Y)=1:"TO",$G(Y)=2:"FROM",1:"") I TYPE'="FROM",TYPE'="TO" Q
D NOW^%DTC S NOWDT=X,Y=% D DD^%DT S NOW=Y,X1=$E(NOWDT,1,5)_"15",X2=-30 D C^%DTC S (Y,MAXDT)=$E(X,1,5)_"00" D DD^%DT S START=Y,MAXDT=($E(MAXDT,1,3)-1)_$E(MAXDT,4,5)_"00"
START S %DT="AEP",%DT("A")="Start Printing Distributions from Date (Month Year): ",%DT("B")=START,%DT(0)=MAXDT W ! D ^%DT K %DT Q:Y<0 S (Y,STARTDT)=$E(Y,1,5) D DD^%DT S END=Y
S %DT="AEP",%DT("A")=" End Printing Distributions with Date (Month Year): ",%DT("B")=END,%DT(0)=-NOWDT D ^%DT K %DT Q:Y<0 S ENDDT=$E(Y,1,5)
I ENDDT<STARTDT W !,"END DATE MUST BE GREATER THAN OR EQUAL TO THE START DATE." G START
S Y=STARTDT D DD^%DT S START=Y W !!,"I will print the distribution history from ",Y," to " S Y=ENDDT D DD^%DT W Y,!! S END=Y
S XP="Do you want to breakout the cost by the MIS costing section",XH="Enter 'YES' to break the costs down to the MIS costing section, '^' to exit."
S %=$$YN^PRCPUYN(1) I '% Q
K MISCOST I %=1 S MISCOST=1
S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
. S ZTDESC="Distribution History Report (to primary)",ZTRTN="DQ^PRCPRPDH"
. S ZTSAVE("PRCP*")="",ZTSAVE("START*")="",ZTSAVE("END*")="",ZTSAVE("NOW*")="",ZTSAVE("TYPE")="",ZTSAVE("MISCOST")="",ZTSAVE("ZTREQ")="@"
W !!,"<*> please wait <*>"
DQ ;queue comes here
N XREF S XREF=$S(TYPE="FROM":"AD",1:"B")
K ^TMP($J,"DISTR"),^TMP($J,"MIS") S DA=0 F S DA=$O(^PRCP(446,XREF,PRCP("I"),DA)) Q:'DA S DATA=$G(^PRCP(446,DA,0)) I DATA'="" S DATE=$P(DATA,"^",2) I DATE'<STARTDT,DATE'>ENDDT D
. S FROM=+$P(DATA,"^",3) I TYPE="FROM" S FROM=+$P(DATA,"^")
. S COSTCNTR=$P(DATA,"^",4) S:'COSTCNTR COSTCNTR="<<UNKNOWN>>" S ^TMP($J,"DISTR",FROM,COSTCNTR)=$G(^TMP($J,"DISTR",FROM,COSTCNTR))+$P(DATA,"^",7)
S PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
S (CUMTOT,FROM)=0 F S FROM=$O(^TMP($J,"DISTR",FROM)) Q:FROM=""!($D(PRCPFLAG)) S NEW=0,INVPT=$P($$INVNAME^PRCPUX1(FROM),"-",2,99) S:INVPT="" INVPT="<<UNKNOWN>>" W !,$E(INVPT,1,17) D
. S TOTAL=0,COSTCNTR="" F S COSTCNTR=$O(^TMP($J,"DISTR",FROM,COSTCNTR)) Q:COSTCNTR=""!($D(PRCPFLAG)) S D=^(COSTCNTR) D
. . W:NEW ! W ?19,$E(COSTCNTR,1,40),?61,$J(D,19,2) S CUMTOT=CUMTOT+D,TOTAL=TOTAL+D,NEW=1
. . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. S MISINVPT=PRCP("I") I TYPE="FROM" S MISINVPT=FROM
. I $G(MISCOST),$O(^PRCP(445,MISINVPT,3,0)) W !?4,"MIS COSTING SECTION",?41,"% DISTRIBUTED",?61,"$ AMOUNT" S MISDA=0 F S MISDA=$O(^PRCP(445,MISINVPT,3,MISDA)) Q:'MISDA!($D(PRCPFLAG)) D
. . S DATA=$G(^PRCP(445,MISINVPT,3,MISDA,0)) Q:DATA=""
. . S X=$P($G(^DIC(49,+$P(DATA,"^"),2)),"^"),X=X_$E(" ",$L(X)+1,5),%=$P($G(^DIC(49,+$P(DATA,"^"),0)),"^") S:%="" %="<<UNKNOWN>>" S %=X_" "_%,X=$J(TOTAL*($P(DATA,"^",2)/100),0,2)
. . S ^TMP($J,"MIS",$E(%,1,40))=$G(^TMP($J,"MIS",$E(%,1,40)))+X
. . W !?4,$E(%,1,40),?44,$J($P(DATA,"^",2),10,2),$J(X,15,2)
. . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. W !?19,"TOTAL $ AMOUNT DISTRIBUTED ",$S(TYPE="FROM":"TO",1:"FROM")," ",$E(INVPT,1,15),?65,$J(TOTAL,15,2),!
. I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
I '$D(PRCPFLAG),$G(MISCOST) D
. I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. I $O(^TMP($J,"MIS",""))'="" W !?4,"MIS COSTING SECTION",?41,"% DISTRIBUTED",?61,"$ AMOUNT" S MISDA=0 F S MISDA=$O(^TMP($J,"MIS",MISDA)) Q:MISDA=""!($D(PRCPFLAG)) S TOTAL=^(MISDA) D
. . W !?4,$E(MISDA,1,40),?44,$J($S(CUMTOT:TOTAL/CUMTOT*100,1:0),10,2),$J(TOTAL,15,2)
. . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. W !?19,"TOTAL DOLLAR AMOUNT DISTRIBUTED ",TYPE," ",PRCP("IN"),?65,$J(CUMTOT,15,2)
I '$D(PRCPFLAG) D END^PRCPUREP
D ^%ZISC K ^TMP($J,"DISTR"),^TMP($J,"MIS") Q
;
H S %=NOW_" PAGE: "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"DISTRIBUTION COSTING REPORT ",TYPE," ",PRCP("IN"),?(80-$L(%)),%,!?10,"FROM DATE ",START," TO DATE ",END
S %="",$P(%,"-",81)="" W !,"DISTRIBUTED ",$S(TYPE="FROM":"TO",1:"FROM"),?19,"COST CENTER",?70,"TOTAL COST",!,% Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRPDH 4635 printed Dec 13, 2024@02:15:16 Page 2
PRCPRPDH ;WISC/RFJ-distribution cost report (to or from primary) ;12 Feb 92
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 NEW %,COSTCNTR,CUMTOT,D,DA,DATA,DATE,END,ENDDT,INVPT,MAXDT,MISCOST,MISDA,MISINVPT,NEW,NOW,NOWDT,PAGE,PRCPFLAG,SCREEN,START,STARTDT,FROM,TOTAL,TYPE,X,Y
+5 SET DIR(0)="S^1:TO;2:FROM;"
SET DIR("A")="Print distributions TO or FROM inventory point"
SET DIR("B")="FROM"
DO ^DIR
KILL DIR
SET TYPE=$SELECT($GET(Y)=1:"TO",$GET(Y)=2:"FROM",1:"")
IF TYPE'="FROM"
IF TYPE'="TO"
QUIT
+6 DO NOW^%DTC
SET NOWDT=X
SET Y=%
DO DD^%DT
SET NOW=Y
SET X1=$EXTRACT(NOWDT,1,5)_"15"
SET X2=-30
DO C^%DTC
SET (Y,MAXDT)=$EXTRACT(X,1,5)_"00"
DO DD^%DT
SET START=Y
SET MAXDT=($EXTRACT(MAXDT,1,3)-1)_$EXTRACT(MAXDT,4,5)_"00"
START SET %DT="AEP"
SET %DT("A")="Start Printing Distributions from Date (Month Year): "
SET %DT("B")=START
SET %DT(0)=MAXDT
WRITE !
DO ^%DT
KILL %DT
if Y<0
QUIT
SET (Y,STARTDT)=$EXTRACT(Y,1,5)
DO DD^%DT
SET END=Y
+1 SET %DT="AEP"
SET %DT("A")=" End Printing Distributions with Date (Month Year): "
SET %DT("B")=END
SET %DT(0)=-NOWDT
DO ^%DT
KILL %DT
if Y<0
QUIT
SET ENDDT=$EXTRACT(Y,1,5)
+2 IF ENDDT<STARTDT
WRITE !,"END DATE MUST BE GREATER THAN OR EQUAL TO THE START DATE."
GOTO START
+3 SET Y=STARTDT
DO DD^%DT
SET START=Y
WRITE !!,"I will print the distribution history from ",Y," to "
SET Y=ENDDT
DO DD^%DT
WRITE Y,!!
SET END=Y
+4 SET XP="Do you want to breakout the cost by the MIS costing section"
SET XH="Enter 'YES' to break the costs down to the MIS costing section, '^' to exit."
+5 SET %=$$YN^PRCPUYN(1)
IF '%
QUIT
+6 KILL MISCOST
IF %=1
SET MISCOST=1
+7 SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+8 SET ZTDESC="Distribution History Report (to primary)"
SET ZTRTN="DQ^PRCPRPDH"
+9 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("START*")=""
SET ZTSAVE("END*")=""
SET ZTSAVE("NOW*")=""
SET ZTSAVE("TYPE")=""
SET ZTSAVE("MISCOST")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
QUIT
+10 WRITE !!,"<*> please wait <*>"
DQ ;queue comes here
+1 NEW XREF
SET XREF=$SELECT(TYPE="FROM":"AD",1:"B")
+2 KILL ^TMP($JOB,"DISTR"),^TMP($JOB,"MIS")
SET DA=0
FOR
SET DA=$ORDER(^PRCP(446,XREF,PRCP("I"),DA))
if 'DA
QUIT
SET DATA=$GET(^PRCP(446,DA,0))
IF DATA'=""
SET DATE=$PIECE(DATA,"^",2)
IF DATE'<STARTDT
IF DATE'>ENDDT
Begin DoDot:1
+3 SET FROM=+$PIECE(DATA,"^",3)
IF TYPE="FROM"
SET FROM=+$PIECE(DATA,"^")
+4 SET COSTCNTR=$PIECE(DATA,"^",4)
if 'COSTCNTR
SET COSTCNTR="<<UNKNOWN>>"
SET ^TMP($JOB,"DISTR",FROM,COSTCNTR)=$GET(^TMP($JOB,"DISTR",FROM,COSTCNTR))+$PIECE(DATA,"^",7)
End DoDot:1
+5 SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+6 SET (CUMTOT,FROM)=0
FOR
SET FROM=$ORDER(^TMP($JOB,"DISTR",FROM))
if FROM=""!($DATA(PRCPFLAG))
QUIT
SET NEW=0
SET INVPT=$PIECE($$INVNAME^PRCPUX1(FROM),"-",2,99)
if INVPT=""
SET INVPT="<<UNKNOWN>>"
WRITE !,$EXTRACT(INVPT,1,17)
Begin DoDot:1
+7 SET TOTAL=0
SET COSTCNTR=""
FOR
SET COSTCNTR=$ORDER(^TMP($JOB,"DISTR",FROM,COSTCNTR))
if COSTCNTR=""!($DATA(PRCPFLAG))
QUIT
SET D=^(COSTCNTR)
Begin DoDot:2
+8 if NEW
WRITE !
WRITE ?19,$EXTRACT(COSTCNTR,1,40),?61,$JUSTIFY(D,19,2)
SET CUMTOT=CUMTOT+D
SET TOTAL=TOTAL+D
SET NEW=1
+9 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:2
+10 SET MISINVPT=PRCP("I")
IF TYPE="FROM"
SET MISINVPT=FROM
+11 IF $GET(MISCOST)
IF $ORDER(^PRCP(445,MISINVPT,3,0))
WRITE !?4,"MIS COSTING SECTION",?41,"% DISTRIBUTED",?61,"$ AMOUNT"
SET MISDA=0
FOR
SET MISDA=$ORDER(^PRCP(445,MISINVPT,3,MISDA))
if 'MISDA!($DATA(PRCPFLAG))
QUIT
Begin DoDot:2
+12 SET DATA=$GET(^PRCP(445,MISINVPT,3,MISDA,0))
if DATA=""
QUIT
+13 SET X=$PIECE($GET(^DIC(49,+$PIECE(DATA,"^"),2)),"^")
SET X=X_$EXTRACT(" ",$LENGTH(X)+1,5)
SET %=$PIECE($GET(^DIC(49,+$PIECE(DATA,"^"),0)),"^")
if %=""
SET %="<<UNKNOWN>>"
SET %=X_" "_%
SET X=$JUSTIFY(TOTAL*($PIECE(DATA,"^",2)/100),0,2)
+14 SET ^TMP($JOB,"MIS",$EXTRACT(%,1,40))=$GET(^TMP($JOB,"MIS",$EXTRACT(%,1,40)))+X
+15 WRITE !?4,$EXTRACT(%,1,40),?44,$JUSTIFY($PIECE(DATA,"^",2),10,2),$JUSTIFY(X,15,2)
+16 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:2
+17 WRITE !?19,"TOTAL $ AMOUNT DISTRIBUTED ",$SELECT(TYPE="FROM":"TO",1:"FROM")," ",$EXTRACT(INVPT,1,15),?65,$JUSTIFY(TOTAL,15,2),!
+18 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+19 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
End DoDot:1
+20 IF '$DATA(PRCPFLAG)
IF $GET(MISCOST)
Begin DoDot:1
+21 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+22 IF $ORDER(^TMP($JOB,"MIS",""))'=""
WRITE !?4,"MIS COSTING SECTION",?41,"% DISTRIBUTED",?61,"$ AMOUNT"
SET MISDA=0
FOR
SET MISDA=$ORDER(^TMP($JOB,"MIS",MISDA))
if MISDA=""!($DATA(PRCPFLAG))
QUIT
SET TOTAL=^(MISDA)
Begin DoDot:2
+23 WRITE !?4,$EXTRACT(MISDA,1,40),?44,$JUSTIFY($SELECT(CUMTOT:TOTAL/CUMTOT*100,1:0),10,2),$JUSTIFY(TOTAL,15,2)
+24 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:2
+25 WRITE !?19,"TOTAL DOLLAR AMOUNT DISTRIBUTED ",TYPE," ",PRCP("IN"),?65,$JUSTIFY(CUMTOT,15,2)
End DoDot:1
+26 IF '$DATA(PRCPFLAG)
DO END^PRCPUREP
+27 DO ^%ZISC
KILL ^TMP($JOB,"DISTR"),^TMP($JOB,"MIS")
QUIT
+28 ;
H SET %=NOW_" PAGE: "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"DISTRIBUTION COSTING REPORT ",TYPE," ",PRCP("IN"),?(80-$LENGTH(%)),%,!?10,"FROM DATE ",START," TO DATE ",END
+2 SET %=""
SET $PIECE(%,"-",81)=""
WRITE !,"DISTRIBUTED ",$SELECT(TYPE="FROM":"TO",1:"FROM"),?19,"COST CENTER",?70,"TOTAL COST",!,%
QUIT
