- 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 Feb 18, 2025@23:41:39 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