PRCPRODA ;WOIFO/VAC-On-Demand Audit Activity Report ; 2/22/07 9:05am
;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
Q
PRIMARY ;This routine displays the audit information on On-Demand Items updates
N X,Y,GROUPALL,SRT,GROUP,ITEMFLG,PERS1,PERSNAM,TIMFLG,GR,GROUPYES
N ITEMSEL,DATESTRT,DATEEND,GRPFLG,DESCR,NOW,ORDER,PRCPFLAG,X1,X2
N POP,ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE
K ^TMP($J,"PRCPRODA")
S DATESTRT=1,DATEEND=9999999
D ^PRCPUSEL Q:'$G(PRCP("I"))
K X S X(1)="The On-Demand Audit Report will print the audit trail for items in Primary and/or Secondary Inventory that are either designated as ODI or were designated as ODI but are not now."
D DISPLAY^PRCPUX2(2,79,.X)
; Prompt for All or single item
K X S X(1)="Select specific items to display."
D DISPLAY^PRCPUX2(2,40,.X)
S ITEMSEL=$$SINGIT^PRCPUX2(PRCP("I"))
I ITEMSEL="^" Q
; set up ^TMP is single item selected, skip remaining prompts
I ITEMSEL'="" D G BEGIN
.S ORDER=ITEMSEL
.S GRPFLG=$P($G(^PRCP(445,PRCP("I"),1,ITEMSEL,0)),"^",21)
.I GRPFLG="" S GRPFLG=0
.S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMSEL)
.S:DESCR="" DESCR=" "
.S I=0 F S I=$O(^PRCP(445,PRCP("I"),1,ITEMSEL,10,I)) Q:+I=0 D
..S TIMFLG=($G(^PRCP(445,PRCP("I"),1,ITEMSEL,10,I,0))*(-1))
..S ^TMP($J,"PRCPRODA",GRPFLG,PRCP("I"),ORDER,TIMFLG)=ITEMSEL_"^"_DESCR_"^"_$G(^PRCP(445,PRCP("I"),1,ITEMSEL,10,I,0))
W !
K X S X(1)="Select the date range which should be used for displaying the usage."
D DISPLAY^PRCPUX2(2,40,.X)
;Select a date range to print
D DATESEL^PRCPURS2("") I '$G(DATEEND) D Q Q
S X1=DATEEND,X2=DATESTRT D ^%DTC
W !,"-- TOTAL NUMBER OF DAYS: ",X+1,!
K X S X(1)=""
K X S X(1)="Select the Group categories to display." D DISPLAY^PRCPUX2(2,40,.X)
D GROUPSEL^PRCPURS1(PRCP("I"))
I '$G(GROUPALL),'$O(^TMP($J,"PRCPURS1","YES",0)) W !,"*** NO GROUP CATEGORIES SELECTED !" D Q Q
W !,"NOTE: The report will",$S('$G(GROUPALL):" NOT",1:"")," include items not stored in a group category."
DESC ; Ask user for Item#/Description sort preference
S SRT=$$SRTPRMP^PRCPUX2(0)
Q:SRT=0
I (+SRT<1)!(SRT>2) G DESC
;
BEGIN S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD,HOME^%ZIS K IO("Q"),ZTSK Q
. S ZTDESC="ON-DEMAND AUDIT REPORT",ZTRTN="DQ^PRCPRODA"
. S ZTSAVE("PRCP*")="",ZTSAVE("GROUP*")="",ZTSAVE("^TMP($J,""PRCPURS1"",")="",ZTSAVE("ZTREQ")="@",ZTSAVE("S*")=""
. S ZTSAVE("DATE*")="",ZTSAVE("ITEM*")=""
W !!,"<*> please wait <*>"
DQ ; queue starts here
N X,Y,%,ITEMDA,D,CTR,DESCR,ORDER,I,PAGE,SCREEN
N PRCPFLAG,GRPDESC,DIST,DAT,DATE0,DATE1,DATE2
I ITEMSEL'="" G REPORT
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S D=$G(^(ITEMDA,0)) I D'="" D
.; If no audit trail quit
.I $G(^PRCP(445,PRCP("I"),1,ITEMDA,10,0))="" Q
.S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA) S:DESCR="" DESCR=" "
.; Determine the Group
.S GROUP=+$P(D,"^",21),GRPFLG=GROUP
.S GROUPYES="NO"
.I $G(GROUPALL)=1 S GROUPYES="YES"
.I $G(GROUPALL)="" D
..S GR="" F S GR=$O(^TMP($J,"PRCPURS1","YES",GR)) Q:GR="" D
...I GR=GRPFLG S GROUPYES="YES"
.Q:GROUPYES="NO"
.I SRT=1 S ORDER=DESCR
.I SRT=2 S ORDER=ITEMDA
.S I=0 F S I=$O(^PRCP(445,PRCP("I"),1,ITEMDA,10,I)) Q:+I=0 D
. . S TIMFLG=+$P($G(^PRCP(445,PRCP("I"),1,ITEMDA,10,I,0)),".",1)
. . Q:TIMFLG<DATESTRT
. . Q:TIMFLG>DATEEND
. . S TIMFLG=TIMFLG*(-1)
. . S ^TMP($J,"PRCPRODA",GRPFLG,PRCP("I"),ORDER,TIMFLG)=ITEMDA_"^"_DESCR_"^"_$G(^PRCP(445,PRCP("I"),1,ITEMDA,10,I,0))
;
REPORT ; Print Report
D NOW^%DTC S Y=% D DD^%DT S NOW=$P(Y,"@",1),PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
;
S GROUP="" F S GROUP=$O(^TMP($J,"PRCPRODA",GROUP)) Q:GROUP="" D Q:$D(PRCPFLAG)
. I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINIATED BY USER >>>" Q
.I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
.I GROUP=0 S GRPDESC="<<NONE>>"
.I GROUP'=0 D
.. S GRPDESC=$$GROUPNM^PRCPEGRP(GROUP)
.. S GRPDESC=$E(GRPDESC,1,20)_" (#"_GROUP_")"
. W !?7,"GROUP: ",GRPDESC,!
. S DIST="" F S DIST=$O(^TMP($J,"PRCPRODA",GROUP,DIST)) Q:DIST="" D Q:$D(PRCPFLAG)
.. S ORDER="" F S ORDER=$O(^TMP($J,"PRCPRODA",GROUP,DIST,ORDER)) Q:ORDER="" D Q:$D(PRCPFLAG)
... S ITEMFLG=""
... S TIMFLG="" F S TIMFLG=$O(^TMP($J,"PRCPRODA",GROUP,DIST,ORDER,TIMFLG)) Q:TIMFLG="" D Q:$D(PRCPFLAG)
.... S ITEMDA=$G(^TMP($J,"PRCPRODA",GROUP,DIST,ORDER,TIMFLG)) Q:ITEMDA=""
.... I ITEMFLG="" D Q:$D(PRCPFLAG)
..... I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
..... W !,$P(ITEMDA,"^",1),?9,$P(ITEMDA,"^",2) S ITEMFLG="X"
....S DATE0=$P(ITEMDA,"^",3),DATE1=$P($$FMTE^XLFDT(DATE0,2),"@",1),DATE2=$P($$FMTE^XLFDT(DATE0,3),"@",2)
....S PERS1=$P(ITEMDA,"^",4),PERSNAM=$P(^VA(200,PERS1,20),"^",2)
....I $Y>(IOSL-5) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
....W !,?9,$P(ITEMDA,"^",6),?12,DATE1,?21,DATE2,?32,$E(PERSNAM,1,15),?49,$E($P(ITEMDA,"^",5),1,30)
... W !
.. W !
I '$G(PRCPFLAG) D END^PRCPUREP
Q D ^%ZISC K ^TMP($J,"PRCPRODA"),^TMP($J,"PRCPURS1")
Q
H ;PRINT HEADING
S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W "ON-DEMAND AUDIT FOR: ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
S %="",$P(%,"-",81)=""
W !,"IM#",?9,"DESCRIPTION"
W !,?32,"INVENTORY POINT"
W !,?3,"SETTING",?12,"DATE/TIME",?38,"USER",?49,"REASON"
W !,%,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRODA 5359 printed Sep 23, 2025@19:51:14 Page 2
PRCPRODA ;WOIFO/VAC-On-Demand Audit Activity Report ; 2/22/07 9:05am
+1 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
PRIMARY ;This routine displays the audit information on On-Demand Items updates
+1 NEW X,Y,GROUPALL,SRT,GROUP,ITEMFLG,PERS1,PERSNAM,TIMFLG,GR,GROUPYES
+2 NEW ITEMSEL,DATESTRT,DATEEND,GRPFLG,DESCR,NOW,ORDER,PRCPFLAG,X1,X2
+3 NEW POP,ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE
+4 KILL ^TMP($JOB,"PRCPRODA")
+5 SET DATESTRT=1
SET DATEEND=9999999
+6 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+7 KILL X
SET X(1)="The On-Demand Audit Report will print the audit trail for items in Primary and/or Secondary Inventory that are either designated as ODI or were designated as ODI but are not now."
+8 DO DISPLAY^PRCPUX2(2,79,.X)
+9 ; Prompt for All or single item
+10 KILL X
SET X(1)="Select specific items to display."
+11 DO DISPLAY^PRCPUX2(2,40,.X)
+12 SET ITEMSEL=$$SINGIT^PRCPUX2(PRCP("I"))
+13 IF ITEMSEL="^"
QUIT
+14 ; set up ^TMP is single item selected, skip remaining prompts
+15 IF ITEMSEL'=""
Begin DoDot:1
+16 SET ORDER=ITEMSEL
+17 SET GRPFLG=$PIECE($GET(^PRCP(445,PRCP("I"),1,ITEMSEL,0)),"^",21)
+18 IF GRPFLG=""
SET GRPFLG=0
+19 SET DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMSEL)
+20 if DESCR=""
SET DESCR=" "
+21 SET I=0
FOR
SET I=$ORDER(^PRCP(445,PRCP("I"),1,ITEMSEL,10,I))
if +I=0
QUIT
Begin DoDot:2
+22 SET TIMFLG=($GET(^PRCP(445,PRCP("I"),1,ITEMSEL,10,I,0))*(-1))
+23 SET ^TMP($JOB,"PRCPRODA",GRPFLG,PRCP("I"),ORDER,TIMFLG)=ITEMSEL_"^"_DESCR_"^"_$GET(^PRCP(445,PRCP("I"),1,ITEMSEL,10,I,0))
End DoDot:2
End DoDot:1
GOTO BEGIN
+24 WRITE !
+25 KILL X
SET X(1)="Select the date range which should be used for displaying the usage."
+26 DO DISPLAY^PRCPUX2(2,40,.X)
+27 ;Select a date range to print
+28 DO DATESEL^PRCPURS2("")
IF '$GET(DATEEND)
DO Q
QUIT
+29 SET X1=DATEEND
SET X2=DATESTRT
DO ^%DTC
+30 WRITE !,"-- TOTAL NUMBER OF DAYS: ",X+1,!
+31 KILL X
SET X(1)=""
+32 KILL X
SET X(1)="Select the Group categories to display."
DO DISPLAY^PRCPUX2(2,40,.X)
+33 DO GROUPSEL^PRCPURS1(PRCP("I"))
+34 IF '$GET(GROUPALL)
IF '$ORDER(^TMP($JOB,"PRCPURS1","YES",0))
WRITE !,"*** NO GROUP CATEGORIES SELECTED !"
DO Q
QUIT
+35 WRITE !,"NOTE: The report will",$SELECT('$GET(GROUPALL):" NOT",1:"")," include items not stored in a group category."
DESC ; Ask user for Item#/Description sort preference
+1 SET SRT=$$SRTPRMP^PRCPUX2(0)
+2 if SRT=0
QUIT
+3 IF (+SRT<1)!(SRT>2)
GOTO DESC
+4 ;
BEGIN SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+1 SET ZTDESC="ON-DEMAND AUDIT REPORT"
SET ZTRTN="DQ^PRCPRODA"
+2 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("GROUP*")=""
SET ZTSAVE("^TMP($J,""PRCPURS1"",")=""
SET ZTSAVE("ZTREQ")="@"
SET ZTSAVE("S*")=""
+3 SET ZTSAVE("DATE*")=""
SET ZTSAVE("ITEM*")=""
End DoDot:1
DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q"),ZTSK
QUIT
+4 WRITE !!,"<*> please wait <*>"
DQ ; queue starts here
+1 NEW X,Y,%,ITEMDA,D,CTR,DESCR,ORDER,I,PAGE,SCREEN
+2 NEW PRCPFLAG,GRPDESC,DIST,DAT,DATE0,DATE1,DATE2
+3 IF ITEMSEL'=""
GOTO REPORT
+4 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
SET D=$GET(^(ITEMDA,0))
IF D'=""
Begin DoDot:1
+5 ; If no audit trail quit
+6 IF $GET(^PRCP(445,PRCP("I"),1,ITEMDA,10,0))=""
QUIT
+7 SET DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
if DESCR=""
SET DESCR=" "
+8 ; Determine the Group
+9 SET GROUP=+$PIECE(D,"^",21)
SET GRPFLG=GROUP
+10 SET GROUPYES="NO"
+11 IF $GET(GROUPALL)=1
SET GROUPYES="YES"
+12 IF $GET(GROUPALL)=""
Begin DoDot:2
+13 SET GR=""
FOR
SET GR=$ORDER(^TMP($JOB,"PRCPURS1","YES",GR))
if GR=""
QUIT
Begin DoDot:3
+14 IF GR=GRPFLG
SET GROUPYES="YES"
End DoDot:3
End DoDot:2
+15 if GROUPYES="NO"
QUIT
+16 IF SRT=1
SET ORDER=DESCR
+17 IF SRT=2
SET ORDER=ITEMDA
+18 SET I=0
FOR
SET I=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,10,I))
if +I=0
QUIT
Begin DoDot:2
+19 SET TIMFLG=+$PIECE($GET(^PRCP(445,PRCP("I"),1,ITEMDA,10,I,0)),".",1)
+20 if TIMFLG<DATESTRT
QUIT
+21 if TIMFLG>DATEEND
QUIT
+22 SET TIMFLG=TIMFLG*(-1)
+23 SET ^TMP($JOB,"PRCPRODA",GRPFLG,PRCP("I"),ORDER,TIMFLG)=ITEMDA_"^"_DESCR_"^"_$GET(^PRCP(445,PRCP("I"),1,ITEMDA,10,I,0))
End DoDot:2
End DoDot:1
+24 ;
REPORT ; Print Report
+1 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=$PIECE(Y,"@",1)
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+2 ;
+3 SET GROUP=""
FOR
SET GROUP=$ORDER(^TMP($JOB,"PRCPRODA",GROUP))
if GROUP=""
QUIT
Begin DoDot:1
+4 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINIATED BY USER >>>"
QUIT
+5 IF $Y>(IOSL-8)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+6 IF GROUP=0
SET GRPDESC="<<NONE>>"
+7 IF GROUP'=0
Begin DoDot:2
+8 SET GRPDESC=$$GROUPNM^PRCPEGRP(GROUP)
+9 SET GRPDESC=$EXTRACT(GRPDESC,1,20)_" (#"_GROUP_")"
End DoDot:2
+10 WRITE !?7,"GROUP: ",GRPDESC,!
+11 SET DIST=""
FOR
SET DIST=$ORDER(^TMP($JOB,"PRCPRODA",GROUP,DIST))
if DIST=""
QUIT
Begin DoDot:2
+12 SET ORDER=""
FOR
SET ORDER=$ORDER(^TMP($JOB,"PRCPRODA",GROUP,DIST,ORDER))
if ORDER=""
QUIT
Begin DoDot:3
+13 SET ITEMFLG=""
+14 SET TIMFLG=""
FOR
SET TIMFLG=$ORDER(^TMP($JOB,"PRCPRODA",GROUP,DIST,ORDER,TIMFLG))
if TIMFLG=""
QUIT
Begin DoDot:4
+15 SET ITEMDA=$GET(^TMP($JOB,"PRCPRODA",GROUP,DIST,ORDER,TIMFLG))
if ITEMDA=""
QUIT
+16 IF ITEMFLG=""
Begin DoDot:5
+17 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+18 WRITE !,$PIECE(ITEMDA,"^",1),?9,$PIECE(ITEMDA,"^",2)
SET ITEMFLG="X"
End DoDot:5
if $DATA(PRCPFLAG)
QUIT
+19 SET DATE0=$PIECE(ITEMDA,"^",3)
SET DATE1=$PIECE($$FMTE^XLFDT(DATE0,2),"@",1)
SET DATE2=$PIECE($$FMTE^XLFDT(DATE0,3),"@",2)
+20 SET PERS1=$PIECE(ITEMDA,"^",4)
SET PERSNAM=$PIECE(^VA(200,PERS1,20),"^",2)
+21 IF $Y>(IOSL-5)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+22 WRITE !,?9,$PIECE(ITEMDA,"^",6),?12,DATE1,?21,DATE2,?32,$EXTRACT(PERSNAM,1,15),?49,$EXTRACT($PIECE(ITEMDA,"^",5),1,30)
End DoDot:4
if $DATA(PRCPFLAG)
QUIT
+23 WRITE !
End DoDot:3
if $DATA(PRCPFLAG)
QUIT
+24 WRITE !
End DoDot:2
if $DATA(PRCPFLAG)
QUIT
End DoDot:1
if $DATA(PRCPFLAG)
QUIT
+25 IF '$GET(PRCPFLAG)
DO END^PRCPUREP
Q DO ^%ZISC
KILL ^TMP($JOB,"PRCPRODA"),^TMP($JOB,"PRCPURS1")
+1 QUIT
H ;PRINT HEADING
+1 SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+2 WRITE "ON-DEMAND AUDIT FOR: ",$EXTRACT(PRCP("IN"),1,20),?(80-$LENGTH(%)),%
+3 SET %=""
SET $PIECE(%,"-",81)=""
+4 WRITE !,"IM#",?9,"DESCRIPTION"
+5 WRITE !,?32,"INVENTORY POINT"
+6 WRITE !,?3,"SETTING",?12,"DATE/TIME",?38,"USER",?49,"REASON"
+7 WRITE !,%,!
+8 QUIT
