- PRCPRPC2 ;WISC/RFJ/DWA-patient distribution costs (print report) ;11 Mar 94
- ;;5.1;IFCAP;**32**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- PRINT ; print report
- D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
- S ORROOM=""
- ; show report variables selected
- W !!?10,"*** R E P O R T V A R I A B L E S S E L E C T E D ***",!
- W !,"SURGICAL SPECIALTY RANGE FROM : ",$S(PRCPSURS="":"FIRST",1:PRCPSURS),?60,"TO: ",$S(PRCPSURE="z":"LAST",1:PRCPSURE)
- W !,"PATIENT NAME RANGE FROM : ",$S(PRCPPATS="":"FIRST",1:PRCPPATS),?60,"TO: ",$S(PRCPPATE="z":"LAST",1:PRCPPATE)
- W !,"OPERATION/PROCEDURE CODE RANGE FROM: ",$S(PRCPOPCS="":"FIRST",1:PRCPOPCS),?60,"TO: ",$S(PRCPOPCE="z":"LAST",1:PRCPOPCE)
- S Y=DATESTRT D DD^%DT W !,"DISTRIBUTION DATES FROM : ",Y S Y=DATEEND D DD^%DT W ?60,"TO: ",Y,!
- W !,"PRINT SUMMARY ONLY : ",$S(PRCPSUMM=1:"YES",1:"NO")
- W !,"PRINT ITEMS ON REPORT: ",$S($G(PRCPFITM)=1:"YES",1:"NO")
- ;
- S DISTRNM="" F S DISTRNM=$O(^TMP($J,"PRCPRPCR",DISTRNM)) Q:DISTRNM=""!($G(PRCPFLAG)) S SURGSPEC="" F S SURGSPEC=$O(^TMP($J,"PRCPRPCR",DISTRNM,SURGSPEC)) Q:SURGSPEC=""!($G(PRCPFLAG)) D
- . I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
- . I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
- . I '$G(PRCPSUMM) W !!?5,"FROM Inventory Point: ",DISTRNM,?40,"TO Surgical Specialty: ",SURGSPEC
- . S INOUTPAT="" F S INOUTPAT=$O(^TMP($J,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT)) Q:INOUTPAT=""!($G(PRCPFLAG)) D
- . . S PATNAME="" F S PATNAME=$O(^TMP($J,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT,PATNAME)) Q:PATNAME=""!($G(PRCPFLAG)) D
- . . . S OPCODE="" F S OPCODE=$O(^TMP($J,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT,PATNAME,OPCODE)) Q:OPCODE=""!($G(PRCPFLAG)) D
- . . . . S DA=0 F S DA=$O(^TMP($J,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT,PATNAME,OPCODE,DA)) Q:'DA!($G(PRCPFLAG)) S DATA=^(DA) D
- . . . . . S SURGEON=$E($$USER^PRCPUREP(+$P(DATA,"^",2)),1,15) I SURGEON="" S SURGEON=" "
- . . . . . S TOTCOST=$P(DATA,"^",3)
- . . . . . ; accumulate totals
- . . . . . S %=$G(^TMP($J,"PRCPRPCRT",1,DISTRNM)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(DISTRNM)=%
- . . . . . S %=$G(^TMP($J,"PRCPRPCRT",2,SURGSPEC)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(SURGSPEC)=%
- . . . . . S %=$G(^TMP($J,"PRCPRPCRT",2,SURGSPEC,INOUTPAT)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(INOUTPAT)=%
- . . . . . S %=$G(^TMP($J,"PRCPRPCRT",3,INOUTPAT)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(INOUTPAT)=%
- . . . . . S %=$G(^TMP($J,"PRCPRPCRT",4,OPCODE)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(OPCODE)=%
- . . . . . S %=$G(^TMP($J,"PRCPRPCRT",5,SURGEON)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(SURGEON)=%
- . . . . . S %=$G(^TMP($J,"PRCPRPCRT",6)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(6)=%
- . . . . . I $G(PRCPSUMM) Q
- . . . . . ;
- . . . . . S Y=DA D DD^%DT S DATE=$P(Y,",")
- . . . . . I $P(DATA,"^")'="" S ORROOM=$E($P($G(^SC($P($G(^SRS(+$P(DATA,"^"),0)),"^"),0)),"^"),1,10)
- . . . . . S:ORROOM="" ORROOM="N/A"
- . . . . . W !,PATNAME,?12,INOUTPAT,?17,OPCODE,?26,DATE,?35,SURGEON,?52,ORROOM,?65,$J(TOTCOST,15,2) S ORROOM=""
- . . . . . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
- . . . . . I $G(PRCPFITM)=1 S ITEMDA=0 F S ITEMDA=$O(^PRCP(446.1,DA,445,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) S DATA=$G(^(ITEMDA,0)) I DATA'="" D
- . . . . . . W !?10,"IM# ",ITEMDA,?20,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,25),?50,"QTY: ",+$P(DATA,"^",2),?65,$J(+$P(DATA,"^",3),15,2)
- . . . . . . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
- I $G(PRCPFLAG) Q
- K ORROOM
- ;
- ; print report totals
- D PRINTOTL^PRCPRPC3
- Q
- ;
- ;
- H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
- W $C(13),"PATIENT DISTRIBUTION COST REPORT FOR: ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
- S %="",$P(%,"-",81)=""
- I $G(PRCPFTOT) W !,"*** R E P O R T T O T A L S ***",?46,$J("COUNT",10),$J("TOTAL COST",12),$J("AVERAGE",12),!,% Q
- W !,"NAME-SSN",?11,"IO",?17,"OPCODE",?26,"DATE",?35,"SURGEON",?52,"OR ROOM",?70,"TOTAL COST",!,%
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRPC2 4433 printed Feb 18, 2025@23:41:36 Page 2
- PRCPRPC2 ;WISC/RFJ/DWA-patient distribution costs (print report) ;11 Mar 94
- +1 ;;5.1;IFCAP;**32**;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- PRINT ; print report
- +1 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET NOW=Y
- SET PAGE=1
- SET SCREEN=$$SCRPAUSE^PRCPUREP
- USE IO
- DO H
- +2 SET ORROOM=""
- +3 ; show report variables selected
- +4 WRITE !!?10,"*** R E P O R T V A R I A B L E S S E L E C T E D ***",!
- +5 WRITE !,"SURGICAL SPECIALTY RANGE FROM : ",$SELECT(PRCPSURS="":"FIRST",1:PRCPSURS),?60,"TO: ",$SELECT(PRCPSURE="z":"LAST",1:PRCPSURE)
- +6 WRITE !,"PATIENT NAME RANGE FROM : ",$SELECT(PRCPPATS="":"FIRST",1:PRCPPATS),?60,"TO: ",$SELECT(PRCPPATE="z":"LAST",1:PRCPPATE)
- +7 WRITE !,"OPERATION/PROCEDURE CODE RANGE FROM: ",$SELECT(PRCPOPCS="":"FIRST",1:PRCPOPCS),?60,"TO: ",$SELECT(PRCPOPCE="z":"LAST",1:PRCPOPCE)
- +8 SET Y=DATESTRT
- DO DD^%DT
- WRITE !,"DISTRIBUTION DATES FROM : ",Y
- SET Y=DATEEND
- DO DD^%DT
- WRITE ?60,"TO: ",Y,!
- +9 WRITE !,"PRINT SUMMARY ONLY : ",$SELECT(PRCPSUMM=1:"YES",1:"NO")
- +10 WRITE !,"PRINT ITEMS ON REPORT: ",$SELECT($GET(PRCPFITM)=1:"YES",1:"NO")
- +11 ;
- +12 SET DISTRNM=""
- FOR
- SET DISTRNM=$ORDER(^TMP($JOB,"PRCPRPCR",DISTRNM))
- if DISTRNM=""!($GET(PRCPFLAG))
- QUIT
- SET SURGSPEC=""
- FOR
- SET SURGSPEC=$ORDER(^TMP($JOB,"PRCPRPCR",DISTRNM,SURGSPEC))
- if SURGSPEC=""!($GET(PRCPFLAG))
- QUIT
- Begin DoDot:1
- +13 IF $GET(ZTQUEUED)
- IF $$S^%ZTLOAD
- SET PRCPFLAG=1
- WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
- QUIT
- +14 IF $Y>(IOSL-8)
- if SCREEN
- DO P^PRCPUREP
- if $DATA(PRCPFLAG)
- QUIT
- DO H
- +15 IF '$GET(PRCPSUMM)
- WRITE !!?5,"FROM Inventory Point: ",DISTRNM,?40,"TO Surgical Specialty: ",SURGSPEC
- +16 SET INOUTPAT=""
- FOR
- SET INOUTPAT=$ORDER(^TMP($JOB,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT))
- if INOUTPAT=""!($GET(PRCPFLAG))
- QUIT
- Begin DoDot:2
- +17 SET PATNAME=""
- FOR
- SET PATNAME=$ORDER(^TMP($JOB,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT,PATNAME))
- if PATNAME=""!($GET(PRCPFLAG))
- QUIT
- Begin DoDot:3
- +18 SET OPCODE=""
- FOR
- SET OPCODE=$ORDER(^TMP($JOB,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT,PATNAME,OPCODE))
- if OPCODE=""!($GET(PRCPFLAG))
- QUIT
- Begin DoDot:4
- +19 SET DA=0
- FOR
- SET DA=$ORDER(^TMP($JOB,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT,PATNAME,OPCODE,DA))
- if 'DA!($GET(PRCPFLAG))
- QUIT
- SET DATA=^(DA)
- Begin DoDot:5
- +20 SET SURGEON=$EXTRACT($$USER^PRCPUREP(+$PIECE(DATA,"^",2)),1,15)
- IF SURGEON=""
- SET SURGEON=" "
- +21 SET TOTCOST=$PIECE(DATA,"^",3)
- +22 ; accumulate totals
- +23 SET %=$GET(^TMP($JOB,"PRCPRPCRT",1,DISTRNM))
- SET $PIECE(%,"^")=$PIECE(%,"^")+1
- SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
- SET ^(DISTRNM)=%
- +24 SET %=$GET(^TMP($JOB,"PRCPRPCRT",2,SURGSPEC))
- SET $PIECE(%,"^")=$PIECE(%,"^")+1
- SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
- SET ^(SURGSPEC)=%
- +25 SET %=$GET(^TMP($JOB,"PRCPRPCRT",2,SURGSPEC,INOUTPAT))
- SET $PIECE(%,"^")=$PIECE(%,"^")+1
- SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
- SET ^(INOUTPAT)=%
- +26 SET %=$GET(^TMP($JOB,"PRCPRPCRT",3,INOUTPAT))
- SET $PIECE(%,"^")=$PIECE(%,"^")+1
- SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
- SET ^(INOUTPAT)=%
- +27 SET %=$GET(^TMP($JOB,"PRCPRPCRT",4,OPCODE))
- SET $PIECE(%,"^")=$PIECE(%,"^")+1
- SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
- SET ^(OPCODE)=%
- +28 SET %=$GET(^TMP($JOB,"PRCPRPCRT",5,SURGEON))
- SET $PIECE(%,"^")=$PIECE(%,"^")+1
- SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
- SET ^(SURGEON)=%
- +29 SET %=$GET(^TMP($JOB,"PRCPRPCRT",6))
- SET $PIECE(%,"^")=$PIECE(%,"^")+1
- SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
- SET ^(6)=%
- +30 IF $GET(PRCPSUMM)
- QUIT
- +31 ;
- +32 SET Y=DA
- DO DD^%DT
- SET DATE=$PIECE(Y,",")
- +33 IF $PIECE(DATA,"^")'=""
- SET ORROOM=$EXTRACT($PIECE($GET(^SC($PIECE($GET(^SRS(+$PIECE(DATA,"^"),0)),"^"),0)),"^"),1,10)
- +34 if ORROOM=""
- SET ORROOM="N/A"
- +35 WRITE !,PATNAME,?12,INOUTPAT,?17,OPCODE,?26,DATE,?35,SURGEON,?52,ORROOM,?65,$JUSTIFY(TOTCOST,15,2)
- SET ORROOM=""
- +36 IF $Y>(IOSL-4)
- if SCREEN
- DO P^PRCPUREP
- if $DATA(PRCPFLAG)
- QUIT
- DO H
- +37 IF $GET(PRCPFITM)=1
- SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(446.1,DA,445,ITEMDA))
- if 'ITEMDA!($GET(PRCPFLAG))
- QUIT
- SET DATA=$GET(^(ITEMDA,0))
- IF DATA'=""
- Begin DoDot:6
- +38 WRITE !?10,"IM# ",ITEMDA,?20,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,25),?50,"QTY: ",+$PIECE(DATA,"^",2),?65,$JUSTIFY(+$PIECE(DATA,"^",3),15,2)
- +39 IF $Y>(IOSL-4)
- if SCREEN
- DO P^PRCPUREP
- if $DATA(PRCPFLAG)
- QUIT
- DO H
- End DoDot:6
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +40 IF $GET(PRCPFLAG)
- QUIT
- +41 KILL ORROOM
- +42 ;
- +43 ; print report totals
- +44 DO PRINTOTL^PRCPRPC3
- +45 QUIT
- +46 ;
- +47 ;
- H SET %=NOW_" PAGE "_PAGE
- SET PAGE=PAGE+1
- IF PAGE'=2!(SCREEN)
- WRITE @IOF
- +1 WRITE $CHAR(13),"PATIENT DISTRIBUTION COST REPORT FOR: ",$EXTRACT(PRCP("IN"),1,20),?(80-$LENGTH(%)),%
- +2 SET %=""
- SET $PIECE(%,"-",81)=""
- +3 IF $GET(PRCPFTOT)
- WRITE !,"*** R E P O R T T O T A L S ***",?46,$JUSTIFY("COUNT",10),$JUSTIFY("TOTAL COST",12),$JUSTIFY("AVERAGE",12),!,%
- QUIT
- +4 WRITE !,"NAME-SSN",?11,"IO",?17,"OPCODE",?26,"DATE",?35,"SURGEON",?52,"OR ROOM",?70,"TOTAL COST",!,%
- +5 QUIT