PRCPRODS ;WOIFO/CC/VAC-On-Demand Conflict Report Secondary ; 2/22/07 9:38am
;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
;*98 Created to identify items in Secondary as ODI but not in Primary
Q
PRIM N CTR,I,ITEM,ITEMNAM,J,SECNAME,TOTREC
N LST,MGRFLG,NOW,NOWDT,PAGE,PRCPFLAG,PRI,PRIM,SCREEN,SEC,SECNAME,SRT,SORT,USER,X,Y,RECCNT,ODIFLAG,ODIFLAG2,PRINAME
N POP,ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE
D ^PRCPUSEL Q:'$G(PRCP("I"))
K ^TMP($J,"PRCPRODS")
S PAGE=1
D NOW^%DTC S NOWDT=X,Y=% D DD^%DT S NOW=Y,SCREEN=$$SCRPAUSE^PRCPUREP
K X S X(1)="The On-Demand Conflict Report shows all items that are On-Demand in the Primary and Standard in the Secondary" D DISPLAY^PRCPUX2(40,79,.X)
S CTR=0
S X="" F S X=$O(^PRCP(445,PRCP("I"),1,"AC",X)) Q:X="" S CTR=CTR+1
I +CTR=0 W !,"NO PRIMARY CROSS REFERENCES EXIST FOR THIS SECONDARY" HANG 5 Q
QUEST ; Select Sort order
S SRT=$$SRTPRMP^PRCPUX2(0)
Q:SRT=0
S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
.S ZTDESC="On Demand Conflict Report",ZTRTN="REPORT^PRCPRODS"
.S ZTSAVE("PRCP*")="",ZTSAVE("REPTYPE")="",ZTSAVE("S*")="",ZTSAVE("END*")="",ZTSAVE("NOW*")="",ZTSAVE("COMDT")="",ZTSAVE("PERCENT")="",ZTSAVE("REP")="",ZTSAVE("ZTREQ")="@"
.S ZTSAVE("S*")="",ZTSAVE("C*")=""
;
QUEST2 W !!,"Please wait. Report compiling and printing."
REPORT ;Now compile the data
S PRIM=""
S PRI="" F S PRI=$O(^PRCP(445,PRCP("I"),1,"AC",PRI)) Q:PRI="" D
.I PRIM="" S PRIM=$P(PRI,";",1)
.I PRIM'=$P(PRI,";",1) D
.. S PRIM=$P(PRI,";",1)
.S ITEM=""
.F S ITEM=$O(^PRCP(445,PRCP("I"),1,"AC",PRI,ITEM)) Q:ITEM="" D
..S ODIFLAG=$$ODITEM^PRCPUX2(PRCP("I"),ITEM)
..S ODIFLAG2=$$ODITEM^PRCPUX2(PRIM,ITEM)
..;S ITEMNAM=$P($G(^PRCP(445,PRCP("I"),1,ITEM,6)),"^",1)
..S ITEMNAM=$$DESCR^PRCPUX1(PRCP("I"),ITEM) S:ITEMNAM="" ITEMNAM=" "
..S SORT=ITEMNAM
..I SRT=2 S SORT=ITEM
..I ODIFLAG2="Y" D
...I (ODIFLAG="N")!(ODIFLAG="") D
....S ^TMP($J,"PRCPRODS",PRCP("I"),PRIM,SORT,ITEM)=ITEMNAM
RPT ;Now print the report
S PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO
S TOTREC=0
S SEC=""
F S SEC=$O(^TMP($J,"PRCPRODS",SEC)) Q:SEC="" D Q:$D(PRCPFLAG)
.S PRIM=""
.F S PRIM=$O(^TMP($J,"PRCPRODS",SEC,PRIM)) Q:PRIM="" D Q:$D(PRCPFLAG)
..S PRINAME=$P($G(^PRCP(445,PRIM,0)),"^",1)
..D:PAGE>1&SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
..S RECCNT=0
..S SORT=""
..F S SORT=$O(^TMP($J,"PRCPRODS",SEC,PRIM,SORT)) Q:SORT="" D Q:$D(PRCPFLAG)
...S ITEM=""
...F S ITEM=$O(^TMP($J,"PRCPRODS",SEC,PRIM,SORT,ITEM)) Q:ITEM="" D Q:$D(PRCPFLAG)
....S ITEMNAM=$G(^TMP($J,"PRCPRODS",SEC,PRIM,SORT,ITEM))
....W !,ITEM,?11,ITEMNAM
....S RECCNT=RECCNT+1,TOTREC=TOTREC+1
....I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
....I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !,?10,"<<<TASKMANAGER JOB TERMINATED BY USER >>>" Q
...I RECCNT=0 W !,"No Records Found",!
...Q
..I '$D(PRCPFLAG) D A
.Q
;
I TOTREC=0 D HEAD2 W !?27,"*** NO CONFLICTS TO PRINT ***"
I '$D(PRCPFLAG) D:SCREEN END^PRCPUREP
D ^%ZISC
D Q Q
;
A ; Print authorized users
I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
S SECNAME=$P($G(^PRCP(445,SEC,0)),"^",1)
W !!,"AUTHORIZED ON-DEMAND USERS"
W !,"--------------------------"
W !,SECNAME,":"
S USER=0 F S USER=$O(^PRCP(445,SEC,4,USER)) Q:USER="" D Q:$D(PRCPFLAG)
.S MGRFLG=""
.I $G(^PRCP(445,SEC,9,0))'="" D
..S LST=$P($G(^PRCP(445,SEC,9,0)),"^",4)
..S J=0
..F I=1:1:LST D Q:$D(PRCPFLAG)
...S J=$O(^PRCP(445,SEC,9,J))
...I $G(^PRCP(445,SEC,9,J,0))=USER D
....I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
....I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
....Q:$D(PRCPFLAG)
....W ?30,$E($$USER^PRCPUREP(USER),1,30),!
...Q:$D(PRCPFLAG)
..Q:$D(PRCPFLAG)
.Q:$D(PRCPFLAG)
D B
Q
B ; Display Primary authorized users
I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
S PRINAME=$P($G(^PRCP(445,PRIM,0)),"^",1)
W !
W $E(PRINAME,1,28),":"
S USER=0 F S USER=$O(^PRCP(445,PRIM,4,USER)) Q:USER="" D Q:$D(PRCPFLAG)
.S MGRFLG=""
.I $G(^PRCP(445,PRIM,9,0))'="" D
..S LST=$P($G(^PRCP(445,PRIM,9,0)),"^",4)
..S J=0
..F I=1:1:LST D Q:$D(PRCPFLAG)
...S J=$O(^PRCP(445,PRIM,9,J))
...I $G(^PRCP(445,PRIM,9,J,0))=USER D Q:$D(PRCPFLAG)
....I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
....I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<<TASKMANAGER JOB TERMINATED BY USER >>>" Q
....W ?30,$E($$USER^PRCPUREP(USER),1,30),!
...Q:$D(PRCPFLAG)
..Q:$D(PRCPFLAG)
.Q:$D(PRCPFLAG)
Q:$D(PRCPFLAG)
Q
;
HEAD ;Display header information
Q:$D(PRCPFLAG)
S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
S SECNAME=$P($G(^PRCP(445,SEC,0)),"^",1)
W !,"ON-DEMAND CONFLICTS IN: ",$E(SECNAME,1,24),?50,%
W !,"PRIMARY INVENTORY POINT: ",PRINAME
W !!,"IM#",?11,"DESCRIPTION"
S %="",$P(%,"-",80)="" W !,%,!
Q
HEAD2 ;Display header if no records found
S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W !,"SECONDARY ON-DEMAND CONFLICT REPORT",?50,%
W !!,"IM#",?11,"DESCRIPTION"
S %="",$P(%,"-",80)="" W !,%,!
Q
Q K ^TMP($J,"PRCPRODS")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRODS 5238 printed Sep 23, 2025@19:51:16 Page 2
PRCPRODS ;WOIFO/CC/VAC-On-Demand Conflict Report Secondary ; 2/22/07 9:38am
+1 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;*98 Created to identify items in Secondary as ODI but not in Primary
+4 QUIT
PRIM NEW CTR,I,ITEM,ITEMNAM,J,SECNAME,TOTREC
+1 NEW LST,MGRFLG,NOW,NOWDT,PAGE,PRCPFLAG,PRI,PRIM,SCREEN,SEC,SECNAME,SRT,SORT,USER,X,Y,RECCNT,ODIFLAG,ODIFLAG2,PRINAME
+2 NEW POP,ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 KILL ^TMP($JOB,"PRCPRODS")
+5 SET PAGE=1
+6 DO NOW^%DTC
SET NOWDT=X
SET Y=%
DO DD^%DT
SET NOW=Y
SET SCREEN=$$SCRPAUSE^PRCPUREP
+7 KILL X
SET X(1)="The On-Demand Conflict Report shows all items that are On-Demand in the Primary and Standard in the Secondary"
DO DISPLAY^PRCPUX2(40,79,.X)
+8 SET CTR=0
+9 SET X=""
FOR
SET X=$ORDER(^PRCP(445,PRCP("I"),1,"AC",X))
if X=""
QUIT
SET CTR=CTR+1
+10 IF +CTR=0
WRITE !,"NO PRIMARY CROSS REFERENCES EXIST FOR THIS SECONDARY"
HANG 5
QUIT
QUEST ; Select Sort order
+1 SET SRT=$$SRTPRMP^PRCPUX2(0)
+2 if SRT=0
QUIT
+3 SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+4 SET ZTDESC="On Demand Conflict Report"
SET ZTRTN="REPORT^PRCPRODS"
+5 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("REPTYPE")=""
SET ZTSAVE("S*")=""
SET ZTSAVE("END*")=""
SET ZTSAVE("NOW*")=""
SET ZTSAVE("COMDT")=""
SET ZTSAVE("PERCENT")=""
SET ZTSAVE("REP")=""
SET ZTSAVE("ZTREQ")="@"
+6 SET ZTSAVE("S*")=""
SET ZTSAVE("C*")=""
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
QUIT
+7 ;
QUEST2 WRITE !!,"Please wait. Report compiling and printing."
REPORT ;Now compile the data
+1 SET PRIM=""
+2 SET PRI=""
FOR
SET PRI=$ORDER(^PRCP(445,PRCP("I"),1,"AC",PRI))
if PRI=""
QUIT
Begin DoDot:1
+3 IF PRIM=""
SET PRIM=$PIECE(PRI,";",1)
+4 IF PRIM'=$PIECE(PRI,";",1)
Begin DoDot:2
+5 SET PRIM=$PIECE(PRI,";",1)
End DoDot:2
+6 SET ITEM=""
+7 FOR
SET ITEM=$ORDER(^PRCP(445,PRCP("I"),1,"AC",PRI,ITEM))
if ITEM=""
QUIT
Begin DoDot:2
+8 SET ODIFLAG=$$ODITEM^PRCPUX2(PRCP("I"),ITEM)
+9 SET ODIFLAG2=$$ODITEM^PRCPUX2(PRIM,ITEM)
+10 ;S ITEMNAM=$P($G(^PRCP(445,PRCP("I"),1,ITEM,6)),"^",1)
+11 SET ITEMNAM=$$DESCR^PRCPUX1(PRCP("I"),ITEM)
if ITEMNAM=""
SET ITEMNAM=" "
+12 SET SORT=ITEMNAM
+13 IF SRT=2
SET SORT=ITEM
+14 IF ODIFLAG2="Y"
Begin DoDot:3
+15 IF (ODIFLAG="N")!(ODIFLAG="")
Begin DoDot:4
+16 SET ^TMP($JOB,"PRCPRODS",PRCP("I"),PRIM,SORT,ITEM)=ITEMNAM
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
RPT ;Now print the report
+1 SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
+2 SET TOTREC=0
+3 SET SEC=""
+4 FOR
SET SEC=$ORDER(^TMP($JOB,"PRCPRODS",SEC))
if SEC=""
QUIT
Begin DoDot:1
+5 SET PRIM=""
+6 FOR
SET PRIM=$ORDER(^TMP($JOB,"PRCPRODS",SEC,PRIM))
if PRIM=""
QUIT
Begin DoDot:2
+7 SET PRINAME=$PIECE($GET(^PRCP(445,PRIM,0)),"^",1)
+8 if PAGE>1&SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO HEAD
+9 SET RECCNT=0
+10 SET SORT=""
+11 FOR
SET SORT=$ORDER(^TMP($JOB,"PRCPRODS",SEC,PRIM,SORT))
if SORT=""
QUIT
Begin DoDot:3
+12 SET ITEM=""
+13 FOR
SET ITEM=$ORDER(^TMP($JOB,"PRCPRODS",SEC,PRIM,SORT,ITEM))
if ITEM=""
QUIT
Begin DoDot:4
+14 SET ITEMNAM=$GET(^TMP($JOB,"PRCPRODS",SEC,PRIM,SORT,ITEM))
+15 WRITE !,ITEM,?11,ITEMNAM
+16 SET RECCNT=RECCNT+1
SET TOTREC=TOTREC+1
+17 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO HEAD
+18 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !,?10,"<<<TASKMANAGER JOB TERMINATED BY USER >>>"
QUIT
End DoDot:4
if $DATA(PRCPFLAG)
QUIT
+19 IF RECCNT=0
WRITE !,"No Records Found",!
+20 QUIT
End DoDot:3
if $DATA(PRCPFLAG)
QUIT
+21 IF '$DATA(PRCPFLAG)
DO A
End DoDot:2
if $DATA(PRCPFLAG)
QUIT
+22 QUIT
End DoDot:1
if $DATA(PRCPFLAG)
QUIT
+23 ;
+24 IF TOTREC=0
DO HEAD2
WRITE !?27,"*** NO CONFLICTS TO PRINT ***"
+25 IF '$DATA(PRCPFLAG)
if SCREEN
DO END^PRCPUREP
+26 DO ^%ZISC
+27 DO Q
QUIT
+28 ;
A ; Print authorized users
+1 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO HEAD
+2 SET SECNAME=$PIECE($GET(^PRCP(445,SEC,0)),"^",1)
+3 WRITE !!,"AUTHORIZED ON-DEMAND USERS"
+4 WRITE !,"--------------------------"
+5 WRITE !,SECNAME,":"
+6 SET USER=0
FOR
SET USER=$ORDER(^PRCP(445,SEC,4,USER))
if USER=""
QUIT
Begin DoDot:1
+7 SET MGRFLG=""
+8 IF $GET(^PRCP(445,SEC,9,0))'=""
Begin DoDot:2
+9 SET LST=$PIECE($GET(^PRCP(445,SEC,9,0)),"^",4)
+10 SET J=0
+11 FOR I=1:1:LST
Begin DoDot:3
+12 SET J=$ORDER(^PRCP(445,SEC,9,J))
+13 IF $GET(^PRCP(445,SEC,9,J,0))=USER
Begin DoDot:4
+14 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO HEAD
+15 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
+16 if $DATA(PRCPFLAG)
QUIT
+17 WRITE ?30,$EXTRACT($$USER^PRCPUREP(USER),1,30),!
End DoDot:4
+18 if $DATA(PRCPFLAG)
QUIT
End DoDot:3
if $DATA(PRCPFLAG)
QUIT
+19 if $DATA(PRCPFLAG)
QUIT
End DoDot:2
+20 if $DATA(PRCPFLAG)
QUIT
End DoDot:1
if $DATA(PRCPFLAG)
QUIT
+21 DO B
+22 QUIT
B ; Display Primary authorized users
+1 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO HEAD
+2 SET PRINAME=$PIECE($GET(^PRCP(445,PRIM,0)),"^",1)
+3 WRITE !
+4 WRITE $EXTRACT(PRINAME,1,28),":"
+5 SET USER=0
FOR
SET USER=$ORDER(^PRCP(445,PRIM,4,USER))
if USER=""
QUIT
Begin DoDot:1
+6 SET MGRFLG=""
+7 IF $GET(^PRCP(445,PRIM,9,0))'=""
Begin DoDot:2
+8 SET LST=$PIECE($GET(^PRCP(445,PRIM,9,0)),"^",4)
+9 SET J=0
+10 FOR I=1:1:LST
Begin DoDot:3
+11 SET J=$ORDER(^PRCP(445,PRIM,9,J))
+12 IF $GET(^PRCP(445,PRIM,9,J,0))=USER
Begin DoDot:4
+13 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO HEAD
+14 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<<TASKMANAGER JOB TERMINATED BY USER >>>"
QUIT
+15 WRITE ?30,$EXTRACT($$USER^PRCPUREP(USER),1,30),!
End DoDot:4
if $DATA(PRCPFLAG)
QUIT
+16 if $DATA(PRCPFLAG)
QUIT
End DoDot:3
if $DATA(PRCPFLAG)
QUIT
+17 if $DATA(PRCPFLAG)
QUIT
End DoDot:2
+18 if $DATA(PRCPFLAG)
QUIT
End DoDot:1
if $DATA(PRCPFLAG)
QUIT
+19 if $DATA(PRCPFLAG)
QUIT
+20 QUIT
+21 ;
HEAD ;Display header information
+1 if $DATA(PRCPFLAG)
QUIT
+2 SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+3 SET SECNAME=$PIECE($GET(^PRCP(445,SEC,0)),"^",1)
+4 WRITE !,"ON-DEMAND CONFLICTS IN: ",$EXTRACT(SECNAME,1,24),?50,%
+5 WRITE !,"PRIMARY INVENTORY POINT: ",PRINAME
+6 WRITE !!,"IM#",?11,"DESCRIPTION"
+7 SET %=""
SET $PIECE(%,"-",80)=""
WRITE !,%,!
+8 QUIT
HEAD2 ;Display header if no records found
+1 SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+2 WRITE !,"SECONDARY ON-DEMAND CONFLICT REPORT",?50,%
+3 WRITE !!,"IM#",?11,"DESCRIPTION"
+4 SET %=""
SET $PIECE(%,"-",80)=""
WRITE !,%,!
+5 QUIT
Q KILL ^TMP($JOB,"PRCPRODS")
+1 QUIT
