- 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 Apr 23, 2025@18:29:40 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
