PSGWCPA1 ;BHAM ISC/PTD,CML-Print Cost Per AOU Report for Selected Date Range - CONTINUED ; 13 Jan 97 / 9:24 AM
;;2.3;Automatic Replenishment/Ward Stock ;**9,21**;4 JAN 94;Build 6
EN1 S AOU=0,PGCT=1,OUT=0,HFLG=0,$P(LN,"-",80)="" I '$O(^TMP("PSGWCPA",$J,0)) D HDR W !,LN,!?5,"NO COST DATA FOUND FOR SELECTED DATE RANGE." G DONE
AOULP S (AOUQD,AOUCST,INACTOT)=0 K WRDDA S AOU=$O(^TMP("PSGWCPA",$J,AOU)) D:('AOU)&(AOUCNT>1)&($O(^TMP("PSGWCPA",$J,"SMWD",0))]"") SMRY G:OUT END G:'AOU DONE
D HDR G:OUT END D:FLG=1 SUB1 D:FLG=2 SUB2 W !?7,"==> ",$P(^PSI(58.1,AOU,0),"^") S DRG=0
DRGLP S DRG=$O(^TMP("PSGWCPA",$J,AOU,DRG)) G:DRG="" WRTOT S LOC=^TMP("PSGWCPA",$J,AOU,DRG)
I FLG=1 S:$Y>(IOSL-6) HFLG=1 D:HFLG HDR G:OUT END D:HFLG SUB1 S HFLG=0 W !?5,DRG,?46,$J($P(LOC,"^"),8,0),?64,$S($P(LOC,"^",2)'="NO DATA":$J($P(LOC,"^",2),10,2),1:"DATA MISSING")
S AOUQD=AOUQD+$P(LOC,"^") I $P(LOC,"^",2)'="NO DATA" S AOUCST=AOUCST+$P(LOC,"^",2) G DRGLP
E S INACTOT=1 G DRGLP
;
WRTOT W !?44 F J=1:1:31 W "-"
W !?39,"TOTAL",?46,$J((AOUQD),8,0),?64,$S(INACTOT=1:"INCOMPLETE",1:$J((AOUCST),10,2)),!!
I '$O(^PSI(58.1,AOU,2,0))!(INACTOT=1) G AOULP
D BRKDN G:OUT END G AOULP
;
DONE I $E(IOST)'="C" W @IOF
I $E(IOST)="C" W !!,"Press RETURN to continue: " R AUTO:DTIME
;PSGW*2.3*21 add PSGWCNM to kill list
END K PSGWCNM,ALL,AOU,AOUCST,AOUQD,BDT,DRG,DRGCST,DRGDA,DRGNAME,DRGNM,DRGQD,CST,EDT,FLG,GRTOT,HFLG,INACTOT,INC,INVDA,INVDT,INVN,J,JJ,SEL,IGDA,L,LN,LOC,LOC1,LOC2,LOCSR,LOCWD,ODA,ODT,PGCT,PRCNT,PRCT,IO("Q"),ZTSK,Y,JJ,AOUCNT,AOULP,AUTO,OUT
K QD,SRNAM,SRLOC,SV,VAR,WDNAM,WDLOC,WD,RETDT,SRV,SRVDA,WARD,WDN,WRDA,WRDDA,PSGWIO,TAB,^TMP("PSGWCPA",$J),ZTSK,ZTIO,G,%,%I,%H D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@" Q
;
HDR ;PRINT REPORT MAIN HEADER
I $E(IOST)="C"&(PGCT>1) S DIR(0)="E" D ^DIR K DIR I Y'=1 S OUT=1 Q
W:$Y @IOF W !?5,"COST 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 !?5,"FOR INVENTORY GROUP - ",$P(^PSI(58.2,IGDA,0),"^")
W !!?53,"DATE: ",$$PSGWDT^PSGWUTL1 S PGCT=PGCT+1
Q
;
SUB1 W !?11,"AREA OF USE",!?46,"QUANTITY",!?5,"ITEM",?45,"DISPENSED",?67,"COST",!,LN
Q
SUB2 W !!?46,"QUANTITY",!?11,"AREA OF USE",?46,"DISPENSED",?67,"COST",!,LN
Q
;
BRKDN ;PRINT THE COST PER WARD AND COST PER SERVICE BREAKDOWN
WARD D:$Y>(IOSL-20) HDR Q:OUT W !?5,$P(^PSI(58.1,AOU,0),"^"),?29,"COST PER WARD/LOCATION",!!?23,"WARD/LOC",?45,"% OF TOTAL",?60,"COST",!," " F J=1:1:54 W "-"
W ! S WRDA=0
WRDLP S WRDA=$O(^PSI(58.1,AOU,2,WRDA)) G:'WRDA SERV S (LOCWD,WRDDA(WRDA))=^PSI(58.1,AOU,2,WRDA,0),WARD=$P(LOCWD,"^"),PRCNT=$P(LOCWD,"^",2)
F J=1:1:2 I $P(LOCWD,"^",J)="" W !,"WARD/LOCATION DATA MISSING" Q
S WDNAM=$P(^SC(WARD,0),"^") W !?14,WDNAM,?48,$J(PRCNT,3),?57,$J(((PRCNT/100)*AOUCST),10,2)
S WDLOC=($S($D(^TMP("PSGWCPA",$J,"SMWD",WDNAM)):^(WDNAM),1:0)+((PRCNT/100)*AOUCST)),^(WDNAM)=WDLOC G WRDLP
;
SERV W !!!!?33,"COST PER SERVICE",!?16,"WARD/LOC",!?24,"SERVICE",?44,"% OF WARD/LOC",?60,"COST",!," " F J=1:1:54 W "-"
S WDN=0
WD S WDN=$O(WRDDA(WDN)) Q:'WDN W !!?14,$P(^SC($P(WRDDA(WDN),"^"),0),"^"),":"
I '$O(^PSI(58.1,AOU,2,WDN,1,0)) W !!?16,"NO SERVICES LISTED FOR WARD/LOCATION." Q
S SRVDA=0
SRLP S SRVDA=$O(^PSI(58.1,AOU,2,WDN,1,SRVDA)) G:'SRVDA WD S LOCSR=^PSI(58.1,AOU,2,WDN,1,SRVDA,0) F J=1:1:2 I $P(LOCSR,"^",J)="" W !,"SERVICE DATA MISSING" Q
S SRV=$P(LOCSR,"^"),PRCT=$P(LOCSR,"^",2),SRNAM=$P(^DIC(42.4,SRV,0),"^") W !?16,SRNAM,?48,$J(PRCT,3),?57,$J(((PRCT/100)*(($P(WRDDA(WDN),"^",2)/100))*AOUCST),10,2)
S SRLOC=$S($D(^TMP("PSGWCPA",$J,"SMSRV",SRNAM)):^(SRNAM),1:0)+(((PRCT/100)*(($P(WRDDA(WDN),"^",2)/100))*AOUCST)),^(SRNAM)=SRLOC G SRLP
;
SMRY ;PRINT SUMMARY PAGES - COST BY WARD & COST BY SERVICE
Q:$O(^TMP("PSGWCPA",$J,"SMWD",0))="" S VAR="WARD/LOCATION",(GRTOT,WD,SV)=0 D HDR Q:OUT D SUB3
F L=0:0 S WD=$O(^TMP("PSGWCPA",$J,"SMWD",WD)) Q:WD="" S CST=^(WD),GRTOT=GRTOT+CST W !?5,WD,?45,$J(CST,8,2)
D TOTLN S VAR="SERVICE",GRTOT=0 D HDR Q:OUT D SUB3
F J=0:0 S SV=$O(^TMP("PSGWCPA",$J,"SMSRV",SV)) Q:SV="" S CST=^(SV),GRTOT=GRTOT+CST W !?5,SV,?45,$J(CST,8,2)
D TOTLN Q
;
SUB3 W !!?27,"COST BY ",VAR," SUMMARY",!!?15,VAR,?48,"COST",! F J=1:1:80 W "-"
Q
;
TOTLN W !!?40 F J=1:1:20 W "=" S TAB=$S(VAR="SERVICE":15,1:9)
W !,?TAB,"TOTAL FOR ALL ",VAR,"S:",?45,$J(GRTOT,8,2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWCPA1 4345 printed Nov 22, 2024@16:49:22 Page 2
PSGWCPA1 ;BHAM ISC/PTD,CML-Print Cost Per AOU Report for Selected Date Range - CONTINUED ; 13 Jan 97 / 9:24 AM
+1 ;;2.3;Automatic Replenishment/Ward Stock ;**9,21**;4 JAN 94;Build 6
EN1 SET AOU=0
SET PGCT=1
SET OUT=0
SET HFLG=0
SET $PIECE(LN,"-",80)=""
IF '$ORDER(^TMP("PSGWCPA",$JOB,0))
DO HDR
WRITE !,LN,!?5,"NO COST DATA FOUND FOR SELECTED DATE RANGE."
GOTO DONE
AOULP SET (AOUQD,AOUCST,INACTOT)=0
KILL WRDDA
SET AOU=$ORDER(^TMP("PSGWCPA",$JOB,AOU))
if ('AOU)&(AOUCNT>1)&($ORDER(^TMP("PSGWCPA",$JOB,"SMWD",0))]"")
DO SMRY
if OUT
GOTO END
if 'AOU
GOTO DONE
+1 DO HDR
if OUT
GOTO END
if FLG=1
DO SUB1
if FLG=2
DO SUB2
WRITE !?7,"==> ",$PIECE(^PSI(58.1,AOU,0),"^")
SET DRG=0
DRGLP SET DRG=$ORDER(^TMP("PSGWCPA",$JOB,AOU,DRG))
if DRG=""
GOTO WRTOT
SET LOC=^TMP("PSGWCPA",$JOB,AOU,DRG)
+1 IF FLG=1
if $Y>(IOSL-6)
SET HFLG=1
if HFLG
DO HDR
if OUT
GOTO END
if HFLG
DO SUB1
SET HFLG=0
WRITE !?5,DRG,?46,$JUSTIFY($PIECE(LOC,"^"),8,0),?64,$SELECT($PIECE(LOC,"^",2)'="NO DATA":$JUSTIFY($PIECE(LOC,"^",2),10,2),1:"DATA MISSING")
+2 SET AOUQD=AOUQD+$PIECE(LOC,"^")
IF $PIECE(LOC,"^",2)'="NO DATA"
SET AOUCST=AOUCST+$PIECE(LOC,"^",2)
GOTO DRGLP
+3 IF '$TEST
SET INACTOT=1
GOTO DRGLP
+4 ;
WRTOT WRITE !?44
FOR J=1:1:31
WRITE "-"
+1 WRITE !?39,"TOTAL",?46,$JUSTIFY((AOUQD),8,0),?64,$SELECT(INACTOT=1:"INCOMPLETE",1:$JUSTIFY((AOUCST),10,2)),!!
+2 IF '$ORDER(^PSI(58.1,AOU,2,0))!(INACTOT=1)
GOTO AOULP
+3 DO BRKDN
if OUT
GOTO END
GOTO AOULP
+4 ;
DONE IF $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST)="C"
WRITE !!,"Press RETURN to continue: "
READ AUTO:DTIME
+2 ;PSGW*2.3*21 add PSGWCNM to kill list
END KILL PSGWCNM,ALL,AOU,AOUCST,AOUQD,BDT,DRG,DRGCST,DRGDA,DRGNAME,DRGNM,DRGQD,CST,EDT,FLG,GRTOT,HFLG,INACTOT,INC,INVDA,INVDT,INVN,J,JJ,SEL,IGDA,L,LN,LOC,LOC1,LOC2,LOCSR,LOCWD,ODA,ODT,PGCT,PRCNT,PRCT,IO("Q"),ZTSK,Y,JJ,AOUCNT,AOULP,AUTO,OUT
+1 KILL QD,SRNAM,SRLOC,SV,VAR,WDNAM,WDLOC,WD,RETDT,SRV,SRVDA,WARD,WDN,WRDA,WRDDA,PSGWIO,TAB,^TMP("PSGWCPA",$JOB),ZTSK,ZTIO,G,%,%I,%H
DO ^%ZISC
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+3 ;
HDR ;PRINT REPORT MAIN HEADER
+1 IF $EXTRACT(IOST)="C"&(PGCT>1)
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF Y'=1
SET OUT=1
QUIT
+2 if $Y
WRITE @IOF
WRITE !?5,"COST 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 !?5,"FOR INVENTORY GROUP - ",$PIECE(^PSI(58.2,IGDA,0),"^")
+3 WRITE !!?53,"DATE: ",$$PSGWDT^PSGWUTL1
SET PGCT=PGCT+1
+4 QUIT
+5 ;
SUB1 WRITE !?11,"AREA OF USE",!?46,"QUANTITY",!?5,"ITEM",?45,"DISPENSED",?67,"COST",!,LN
+1 QUIT
SUB2 WRITE !!?46,"QUANTITY",!?11,"AREA OF USE",?46,"DISPENSED",?67,"COST",!,LN
+1 QUIT
+2 ;
BRKDN ;PRINT THE COST PER WARD AND COST PER SERVICE BREAKDOWN
WARD if $Y>(IOSL-20)
DO HDR
if OUT
QUIT
WRITE !?5,$PIECE(^PSI(58.1,AOU,0),"^"),?29,"COST PER WARD/LOCATION",!!?23,"WARD/LOC",?45,"% OF TOTAL",?60,"COST",!," "
FOR J=1:1:54
WRITE "-"
+1 WRITE !
SET WRDA=0
WRDLP SET WRDA=$ORDER(^PSI(58.1,AOU,2,WRDA))
if 'WRDA
GOTO SERV
SET (LOCWD,WRDDA(WRDA))=^PSI(58.1,AOU,2,WRDA,0)
SET WARD=$PIECE(LOCWD,"^")
SET PRCNT=$PIECE(LOCWD,"^",2)
+1 FOR J=1:1:2
IF $PIECE(LOCWD,"^",J)=""
WRITE !,"WARD/LOCATION DATA MISSING"
QUIT
+2 SET WDNAM=$PIECE(^SC(WARD,0),"^")
WRITE !?14,WDNAM,?48,$JUSTIFY(PRCNT,3),?57,$JUSTIFY(((PRCNT/100)*AOUCST),10,2)
+3 SET WDLOC=($SELECT($DATA(^TMP("PSGWCPA",$JOB,"SMWD",WDNAM)):^(WDNAM),1:0)+((PRCNT/100)*AOUCST))
SET ^(WDNAM)=WDLOC
GOTO WRDLP
+4 ;
SERV WRITE !!!!?33,"COST PER SERVICE",!?16,"WARD/LOC",!?24,"SERVICE",?44,"% OF WARD/LOC",?60,"COST",!," "
FOR J=1:1:54
WRITE "-"
+1 SET WDN=0
WD SET WDN=$ORDER(WRDDA(WDN))
if 'WDN
QUIT
WRITE !!?14,$PIECE(^SC($PIECE(WRDDA(WDN),"^"),0),"^"),":"
+1 IF '$ORDER(^PSI(58.1,AOU,2,WDN,1,0))
WRITE !!?16,"NO SERVICES LISTED FOR WARD/LOCATION."
QUIT
+2 SET SRVDA=0
SRLP SET SRVDA=$ORDER(^PSI(58.1,AOU,2,WDN,1,SRVDA))
if 'SRVDA
GOTO WD
SET LOCSR=^PSI(58.1,AOU,2,WDN,1,SRVDA,0)
FOR J=1:1:2
IF $PIECE(LOCSR,"^",J)=""
WRITE !,"SERVICE DATA MISSING"
QUIT
+1 SET SRV=$PIECE(LOCSR,"^")
SET PRCT=$PIECE(LOCSR,"^",2)
SET SRNAM=$PIECE(^DIC(42.4,SRV,0),"^")
WRITE !?16,SRNAM,?48,$JUSTIFY(PRCT,3),?57,$JUSTIFY(((PRCT/100)*(($PIECE(WRDDA(WDN),"^",2)/100))*AOUCST),10,2)
+2 SET SRLOC=$SELECT($DATA(^TMP("PSGWCPA",$JOB,"SMSRV",SRNAM)):^(SRNAM),1:0)+(((PRCT/100)*(($PIECE(WRDDA(WDN),"^",2)/100))*AOUCST))
SET ^(SRNAM)=SRLOC
GOTO SRLP
+3 ;
SMRY ;PRINT SUMMARY PAGES - COST BY WARD & COST BY SERVICE
+1 if $ORDER(^TMP("PSGWCPA",$JOB,"SMWD",0))=""
QUIT
SET VAR="WARD/LOCATION"
SET (GRTOT,WD,SV)=0
DO HDR
if OUT
QUIT
DO SUB3
+2 FOR L=0:0
SET WD=$ORDER(^TMP("PSGWCPA",$JOB,"SMWD",WD))
if WD=""
QUIT
SET CST=^(WD)
SET GRTOT=GRTOT+CST
WRITE !?5,WD,?45,$JUSTIFY(CST,8,2)
+3 DO TOTLN
SET VAR="SERVICE"
SET GRTOT=0
DO HDR
if OUT
QUIT
DO SUB3
+4 FOR J=0:0
SET SV=$ORDER(^TMP("PSGWCPA",$JOB,"SMSRV",SV))
if SV=""
QUIT
SET CST=^(SV)
SET GRTOT=GRTOT+CST
WRITE !?5,SV,?45,$JUSTIFY(CST,8,2)
+5 DO TOTLN
QUIT
+6 ;
SUB3 WRITE !!?27,"COST BY ",VAR," SUMMARY",!!?15,VAR,?48,"COST",!
FOR J=1:1:80
WRITE "-"
+1 QUIT
+2 ;
TOTLN WRITE !!?40
FOR J=1:1:20
WRITE "="
SET TAB=$SELECT(VAR="SERVICE":15,1:9)
+1 WRITE !,?TAB,"TOTAL FOR ALL ",VAR,"S:",?45,$JUSTIFY(GRTOT,8,2)
+2 QUIT
