PRCPRODM ;WOIFO/CC/VAC-On-Demand Conflict Report ; 2/21/07 11:22am
;;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 Primary as ODI but not in Secondary
Q
PRIM I $G(PRCP("DPTYPE"))="S" D PRIM^PRCPRODS Q
N CHOICE,CTR,DATA2,DATA3,DISFLG,DISPT,DISTR,GROUP,GROUPALL,GROUPNM,I,IT,ITEM,ITEMNM,ITNAME,J
N LST,MGRFLG,NOW,NOWDT,ODITEM,ODIUSER,ORD,PAGE,PRCPFLAG,PRI,PRIM,SCREEN,SEC,SECNAME,SRT,USER,X,Y,MAN,RECCNT,GR,GROUPYES
N POP,ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE
K ^TMP($J,"PRIM"),^TMP($J,"SEC"),^TMP($J,"COMB")
S PAGE=1
D NOW^%DTC S NOWDT=X,Y=% D DD^%DT S NOW=Y,SCREEN=$$SCRPAUSE^PRCPUREP
D ^PRCPUSEL Q:'$G(PRCP("I"))
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=$P($G(^PRCP(445,PRCP("I"),2,0)),"^",4)
I +CTR=0 W !,"NO DISTRIBUTION POINTS EXIST FOR THIS PRIMARY" HANG 5 Q
S DISTR=0 F I=1:1:CTR S DISTR=$O(^PRCP(445,PRCP("I"),2,DISTR)) Q:'DISTR!($G(PRCPFLAG)) D
.S $P(DISPT(PRCP("I"),DISTR),"^",2)=$$INVNAME^PRCPUX1(DISTR)
QUEST0 ;
K X S X(1)="Select the DISTRIBUTION POINTS to display" D DISPLAY^PRCPUX2(2,40,.X)
D DISTRSEL^PRCPURS3(PRCP("I"))
QUEST1 ;
S DISFLG=""
I $D(^TMP($J,"PRCPURS3","YES"))=0 D FILL G QUEST3
S X="" F S X=$O(^TMP($J,"PRCPURS3","YES",X)) Q:X="" D
. S $P(DISPT(PRCP("I"),X),"^",1)="*"
QUEST3 ; Select Groups
S DISTR=""
F S DISTR=$O(DISPT(PRCP("I"),DISTR)) Q:DISTR="" D
.I $P(DISPT(PRCP("I"),DISTR),"^",1)["*" S DISFLG="Y"
I DISFLG="" W !,"No Distribution Points picked. Try again." HANG 5 G QUEST0
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."
QUEST4 ; Select Sort order
K X S X(1)="Select the order in which you want the item information to appear." D DISPLAY^PRCPUX2(2,40,.X)
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 D ^%ZISC Q
. S ZTDESC="On-Demand Conflict Report",ZTRTN="REPORT^PRCPRODM"
. S ZTSAVE("S*")="",ZTSAVE("PRCP*")="",ZTSAVE("GR*")="",ZTSAVE("D*")="",ZTSAVE("P*")="",ZTSAVE("C*")="",ZTSAVE("I*")="",ZTSAVE("N*")=""
. S ZTSAVE("^TMP($J,""PRCPURS3"",")="",ZTSAVE("O*")="",ZTSAVE("U*")=""
;
QUEST5 W !!,"Please wait. Report compiling and printing."
REPORT ;Now compile the data
S PRI=PRCP("I")
S PRIM(PRI)=$P(PRCP("PAR"),"^",1)
S ITEM=0 F I=1:1 S ITEM=$O(^PRCP(445,PRI,1,ITEM)) Q:+ITEM=0 D
.S ODITEM=$$ODITEM^PRCPUX2(PRI,ITEM)
.I ODITEM'="Y" Q
.S ^TMP($J,"PRIM",ITEM)=$$DESCR^PRCPUX1(PRI,ITEM)
.S:^TMP($J,"PRIM",ITEM)="" ^TMP($J,"PRIM",ITEM)=" "
;Now get items in secondaries that match
S DISTR="" F I=1:1 S DISTR=$O(DISPT(PRI,DISTR)) Q:DISTR="" D
.Q:$P($G(DISPT(PRI,DISTR)),"^",1)'="*"
.S ITEM=0 F J=1:1 S ITEM=$O(^TMP($J,"PRIM",ITEM)) Q:+ITEM=0 D
..Q:$G(^PRCP(445,DISTR,1,ITEM,0))=""
..S ODITEM=$$ODITEM^PRCPUX2(DISTR,ITEM)
..S MAN=$P($G(^PRCP(445,DISTR,1,ITEM,0)),"^",12)
..I PRI'=$P(MAN,";",1) Q
..I ODITEM="Y" Q
..S $P(^TMP($J,"SEC",DISTR,ITEM),"^",1)=^TMP($J,"PRIM",ITEM)
; Now put in order by group and sort sequence
S DISTR="" F S DISTR=$O(^TMP($J,"SEC",DISTR)) Q:DISTR="" D
.S ITEM="" F S ITEM=$O(^TMP($J,"SEC",DISTR,ITEM)) Q:ITEM="" D
..S DATA2=$G(^PRCP(445,PRI,1,ITEM,0))
..Q:DATA2=""
..S GROUP=+$P(DATA2,"^",21)
..;Determine if the item is in the group
..S GROUPYES="YES"
..I $G(GROUPALL)="" S GROUPYES="NO" D
...S GR="" F S GR=$O(^TMP($J,"PRCPURS1","YES",GR)) Q:GR="" D
....I GR=GROUP S GROUPYES="YES"
..Q:GROUPYES="NO"
..S GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
..I GROUPNM'="" S GROUP=$P(GROUPNM,":",2)
..I GROUPNM="" S GROUP=+GROUPNM
..S ITEMNM=$P($G(^TMP($J,"SEC",DISTR,ITEM)),"^",1)
..S ORD=ITEM
..I SRT=1 S ORD=ITEMNM
..S ^TMP($J,"COMB",PRI,DISTR,GROUP,ORD)=ITEM_"^"_ITEMNM
REP ;Now print the report
S PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO
S RECCNT=0
S PRIM="" F S PRIM=$O(^TMP($J,"COMB",PRIM)) Q:PRIM="" D Q:$D(PRCPFLAG)
.S SEC="" F S SEC=$O(^TMP($J,"COMB",PRIM,SEC)) Q:SEC="" D Q:$D(PRCPFLAG)
..D:PAGE>1&SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
..S GROUP="" F S GROUP=$O(^TMP($J,"COMB",PRIM,SEC,GROUP)) Q:GROUP="" D Q:$D(PRCPFLAG)
...I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
...Q:$D(PRCPFLAG)
...I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !,?10,"<<<TASKMANAGER JOB TERMINATED BY USER >>>"
...W !,"GROUP: " I GROUP'=0 W GROUP,!
...I GROUP=0 W "<<NONE>>",!
...S ORD="" F S ORD=$O(^TMP($J,"COMB",PRIM,SEC,GROUP,ORD)) Q:ORD="" D Q:$D(PRCPFLAG)
....S DATA3=$G(^TMP($J,"COMB",PRIM,SEC,GROUP,ORD))
....S IT=$P(DATA3,"^",1),ITNAME=$P(DATA3,"^",2)
....S RECCNT=RECCNT+1
....I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
....Q:$D(PRCPFLAG)
....I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
....Q:$D(PRCPFLAG)
....W ?1,IT,?11,ITNAME,!
...Q:$D(PRCPFLAG)
..Q:$D(PRCPFLAG)
..; Print authorized users
..I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
..W !!,"AUTHORIZED ON-DEMAND USERS"
..W !,"--------------------------",!
..; I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
..W PRIM(PRI),":"
..S USER=0 F S USER=$O(^PRCP(445,PRI,4,USER)) Q:USER="" D Q:$D(PRCPFLAG)
...S MGRFLG=""
...I $G(^PRCP(445,PRI,9,0))'="" D
....S LST=$P($G(^PRCP(445,PRI,9,0)),"^",4)
....S ODIUSER=0 F S ODIUSER=$O(^PRCP(445,PRI,9,ODIUSER)) Q:+ODIUSER=0 D Q:$D(PRCPFLAG)
.....I $G(^PRCP(445,PRI,9,ODIUSER,0))=USER D
......I $Y>(IOSL-5) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
......W ?30,$E($$USER^PRCPUREP(USER),1,30),!
......Q:$D(PRCPFLAG)
.....Q:$D(PRCPFLAG)
....Q:$D(PRCPFLAG)
...Q:$D(PRCPFLAG)
..Q:$D(PRCPFLAG)
..;Display secondary authorized users
..S SECNAME=$P($G(^PRCP(445,SEC,0)),"^",1)
..W !,$E(SECNAME,1,28),":"
..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 ODIUSER=0
....F S ODIUSER=$O(^PRCP(445,SEC,9,ODIUSER)) Q:+ODIUSER=0 D Q:$D(PRCPFLAG)
.....I $G(^PRCP(445,SEC,9,ODIUSER,0))=USER D
......I $Y>(IOSL-5) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
......W ?30,$E($$USER^PRCPUREP(USER),1,30),!
......Q:$D(PRCPFLAG)
.....Q:$D(PRCPFLAG)
....Q:$D(PRCPFLAG)
...Q:$D(PRCPFLAG)
..Q:$D(PRCPFLAG)
.Q:$D(PRCPFLAG)
I RECCNT=0 D HEAD2 W !,?27,"*** NO CONFLICTS TO PRINT ***",!
D END^PRCPUREP
D Q Q
;
DISPL ; Display the information about the secondaries
S DISTR="" F J=1:1 S DISTR=$O(DISPT(PRCP("I"),DISTR)) Q:DISTR="" D
. W !,?1,DISTR,?6,$P(DISPT(PRCP("I"),DISTR),"^",1),?8,$P(DISPT(PRCP("I"),DISTR),"^",2)
Q
FILL S DISTR="" F I=1:1 S DISTR=$O(DISPT(PRCP("I"),DISTR)) Q:DISTR="" S $P(DISPT(PRCP("I"),DISTR),"^",1)="*"
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),?48,%
W !,"PRIMARY INVENTORY POINT: ",PRIM(PRI)
W !!,"IM#",?11,"DESCRIPTION"
S %="",$P(%,"-",80)="" W !,%,!
K PRCPFLAG
Q
HEAD2 S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W !,"ON-DEMAND CONFLICT REPORT",?48,%
W !,"PRIMARY INVENTORY POINT: ",PRIM(PRI)
W !!,"IM#",?11,"DESCRIPTION"
S %="",$P(%,"-",80)="" W !,%,!
Q
Q D ^%ZISC K ^TMP($J,"PRIM"),^TMP($J,"SEC"),^TMP($J,"COMB")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRODM 7695 printed Dec 13, 2024@02:15:11 Page 2
PRCPRODM ;WOIFO/CC/VAC-On-Demand Conflict Report ; 2/21/07 11:22am
+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 Primary as ODI but not in Secondary
+4 QUIT
PRIM IF $GET(PRCP("DPTYPE"))="S"
DO PRIM^PRCPRODS
QUIT
+1 NEW CHOICE,CTR,DATA2,DATA3,DISFLG,DISPT,DISTR,GROUP,GROUPALL,GROUPNM,I,IT,ITEM,ITEMNM,ITNAME,J
+2 NEW LST,MGRFLG,NOW,NOWDT,ODITEM,ODIUSER,ORD,PAGE,PRCPFLAG,PRI,PRIM,SCREEN,SEC,SECNAME,SRT,USER,X,Y,MAN,RECCNT,GR,GROUPYES
+3 NEW POP,ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE
+4 KILL ^TMP($JOB,"PRIM"),^TMP($JOB,"SEC"),^TMP($JOB,"COMB")
+5 SET PAGE=1
+6 DO NOW^%DTC
SET NOWDT=X
SET Y=%
DO DD^%DT
SET NOW=Y
SET SCREEN=$$SCRPAUSE^PRCPUREP
+7 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+8 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)
+9 SET CTR=$PIECE($GET(^PRCP(445,PRCP("I"),2,0)),"^",4)
+10 IF +CTR=0
WRITE !,"NO DISTRIBUTION POINTS EXIST FOR THIS PRIMARY"
HANG 5
QUIT
+11 SET DISTR=0
FOR I=1:1:CTR
SET DISTR=$ORDER(^PRCP(445,PRCP("I"),2,DISTR))
if 'DISTR!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+12 SET $PIECE(DISPT(PRCP("I"),DISTR),"^",2)=$$INVNAME^PRCPUX1(DISTR)
End DoDot:1
QUEST0 ;
+1 KILL X
SET X(1)="Select the DISTRIBUTION POINTS to display"
DO DISPLAY^PRCPUX2(2,40,.X)
+2 DO DISTRSEL^PRCPURS3(PRCP("I"))
QUEST1 ;
+1 SET DISFLG=""
+2 IF $DATA(^TMP($JOB,"PRCPURS3","YES"))=0
DO FILL
GOTO QUEST3
+3 SET X=""
FOR
SET X=$ORDER(^TMP($JOB,"PRCPURS3","YES",X))
if X=""
QUIT
Begin DoDot:1
+4 SET $PIECE(DISPT(PRCP("I"),X),"^",1)="*"
End DoDot:1
QUEST3 ; Select Groups
+1 SET DISTR=""
+2 FOR
SET DISTR=$ORDER(DISPT(PRCP("I"),DISTR))
if DISTR=""
QUIT
Begin DoDot:1
+3 IF $PIECE(DISPT(PRCP("I"),DISTR),"^",1)["*"
SET DISFLG="Y"
End DoDot:1
+4 IF DISFLG=""
WRITE !,"No Distribution Points picked. Try again."
HANG 5
GOTO QUEST0
+5 KILL X
SET X(1)="Select the Group Categories to display"
DO DISPLAY^PRCPUX2(2,40,.X)
+6 DO GROUPSEL^PRCPURS1(PRCP("I"))
+7 IF '$GET(GROUPALL)
IF '$ORDER(^TMP($JOB,"PRCPURS1","YES",0))
WRITE !,"*** NO GROUP CATEGORIES SELECTED !"
DO Q
QUIT
+8 WRITE !,"NOTE: The report will",$SELECT('$GET(GROUPALL):" NOT",1:"")," include items not stored in a group category."
QUEST4 ; Select Sort order
+1 KILL X
SET X(1)="Select the order in which you want the item information to appear."
DO DISPLAY^PRCPUX2(2,40,.X)
+2 SET SRT=$$SRTPRMP^PRCPUX2(0)
+3 if SRT=0
QUIT
+4 SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTDESC="On-Demand Conflict Report"
SET ZTRTN="REPORT^PRCPRODM"
+6 SET ZTSAVE("S*")=""
SET ZTSAVE("PRCP*")=""
SET ZTSAVE("GR*")=""
SET ZTSAVE("D*")=""
SET ZTSAVE("P*")=""
SET ZTSAVE("C*")=""
SET ZTSAVE("I*")=""
SET ZTSAVE("N*")=""
+7 SET ZTSAVE("^TMP($J,""PRCPURS3"",")=""
SET ZTSAVE("O*")=""
SET ZTSAVE("U*")=""
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
DO ^%ZISC
QUIT
+8 ;
QUEST5 WRITE !!,"Please wait. Report compiling and printing."
REPORT ;Now compile the data
+1 SET PRI=PRCP("I")
+2 SET PRIM(PRI)=$PIECE(PRCP("PAR"),"^",1)
+3 SET ITEM=0
FOR I=1:1
SET ITEM=$ORDER(^PRCP(445,PRI,1,ITEM))
if +ITEM=0
QUIT
Begin DoDot:1
+4 SET ODITEM=$$ODITEM^PRCPUX2(PRI,ITEM)
+5 IF ODITEM'="Y"
QUIT
+6 SET ^TMP($JOB,"PRIM",ITEM)=$$DESCR^PRCPUX1(PRI,ITEM)
+7 if ^TMP($JOB,"PRIM",ITEM)=""
SET ^TMP($JOB,"PRIM",ITEM)=" "
End DoDot:1
+8 ;Now get items in secondaries that match
+9 SET DISTR=""
FOR I=1:1
SET DISTR=$ORDER(DISPT(PRI,DISTR))
if DISTR=""
QUIT
Begin DoDot:1
+10 if $PIECE($GET(DISPT(PRI,DISTR)),"^",1)'="*"
QUIT
+11 SET ITEM=0
FOR J=1:1
SET ITEM=$ORDER(^TMP($JOB,"PRIM",ITEM))
if +ITEM=0
QUIT
Begin DoDot:2
+12 if $GET(^PRCP(445,DISTR,1,ITEM,0))=""
QUIT
+13 SET ODITEM=$$ODITEM^PRCPUX2(DISTR,ITEM)
+14 SET MAN=$PIECE($GET(^PRCP(445,DISTR,1,ITEM,0)),"^",12)
+15 IF PRI'=$PIECE(MAN,";",1)
QUIT
+16 IF ODITEM="Y"
QUIT
+17 SET $PIECE(^TMP($JOB,"SEC",DISTR,ITEM),"^",1)=^TMP($JOB,"PRIM",ITEM)
End DoDot:2
End DoDot:1
+18 ; Now put in order by group and sort sequence
+19 SET DISTR=""
FOR
SET DISTR=$ORDER(^TMP($JOB,"SEC",DISTR))
if DISTR=""
QUIT
Begin DoDot:1
+20 SET ITEM=""
FOR
SET ITEM=$ORDER(^TMP($JOB,"SEC",DISTR,ITEM))
if ITEM=""
QUIT
Begin DoDot:2
+21 SET DATA2=$GET(^PRCP(445,PRI,1,ITEM,0))
+22 if DATA2=""
QUIT
+23 SET GROUP=+$PIECE(DATA2,"^",21)
+24 ;Determine if the item is in the group
+25 SET GROUPYES="YES"
+26 IF $GET(GROUPALL)=""
SET GROUPYES="NO"
Begin DoDot:3
+27 SET GR=""
FOR
SET GR=$ORDER(^TMP($JOB,"PRCPURS1","YES",GR))
if GR=""
QUIT
Begin DoDot:4
+28 IF GR=GROUP
SET GROUPYES="YES"
End DoDot:4
End DoDot:3
+29 if GROUPYES="NO"
QUIT
+30 SET GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
+31 IF GROUPNM'=""
SET GROUP=$PIECE(GROUPNM,":",2)
+32 IF GROUPNM=""
SET GROUP=+GROUPNM
+33 SET ITEMNM=$PIECE($GET(^TMP($JOB,"SEC",DISTR,ITEM)),"^",1)
+34 SET ORD=ITEM
+35 IF SRT=1
SET ORD=ITEMNM
+36 SET ^TMP($JOB,"COMB",PRI,DISTR,GROUP,ORD)=ITEM_"^"_ITEMNM
End DoDot:2
End DoDot:1
REP ;Now print the report
+1 SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
+2 SET RECCNT=0
+3 SET PRIM=""
FOR
SET PRIM=$ORDER(^TMP($JOB,"COMB",PRIM))
if PRIM=""
QUIT
Begin DoDot:1
+4 SET SEC=""
FOR
SET SEC=$ORDER(^TMP($JOB,"COMB",PRIM,SEC))
if SEC=""
QUIT
Begin DoDot:2
+5 if PAGE>1&SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO HEAD
+6 SET GROUP=""
FOR
SET GROUP=$ORDER(^TMP($JOB,"COMB",PRIM,SEC,GROUP))
if GROUP=""
QUIT
Begin DoDot:3
+7 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO HEAD
+8 if $DATA(PRCPFLAG)
QUIT
+9 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !,?10,"<<<TASKMANAGER JOB TERMINATED BY USER >>>"
+10 WRITE !,"GROUP: "
IF GROUP'=0
WRITE GROUP,!
+11 IF GROUP=0
WRITE "<<NONE>>",!
+12 SET ORD=""
FOR
SET ORD=$ORDER(^TMP($JOB,"COMB",PRIM,SEC,GROUP,ORD))
if ORD=""
QUIT
Begin DoDot:4
+13 SET DATA3=$GET(^TMP($JOB,"COMB",PRIM,SEC,GROUP,ORD))
+14 SET IT=$PIECE(DATA3,"^",1)
SET ITNAME=$PIECE(DATA3,"^",2)
+15 SET RECCNT=RECCNT+1
+16 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO HEAD
+17 if $DATA(PRCPFLAG)
QUIT
+18 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
+19 if $DATA(PRCPFLAG)
QUIT
+20 WRITE ?1,IT,?11,ITNAME,!
End DoDot:4
if $DATA(PRCPFLAG)
QUIT
+21 if $DATA(PRCPFLAG)
QUIT
End DoDot:3
if $DATA(PRCPFLAG)
QUIT
+22 if $DATA(PRCPFLAG)
QUIT
+23 ; Print authorized users
+24 IF $Y>(IOSL-8)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO HEAD
+25 WRITE !!,"AUTHORIZED ON-DEMAND USERS"
+26 WRITE !,"--------------------------",!
+27 ; I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
+28 WRITE PRIM(PRI),":"
+29 SET USER=0
FOR
SET USER=$ORDER(^PRCP(445,PRI,4,USER))
if USER=""
QUIT
Begin DoDot:3
+30 SET MGRFLG=""
+31 IF $GET(^PRCP(445,PRI,9,0))'=""
Begin DoDot:4
+32 SET LST=$PIECE($GET(^PRCP(445,PRI,9,0)),"^",4)
+33 SET ODIUSER=0
FOR
SET ODIUSER=$ORDER(^PRCP(445,PRI,9,ODIUSER))
if +ODIUSER=0
QUIT
Begin DoDot:5
+34 IF $GET(^PRCP(445,PRI,9,ODIUSER,0))=USER
Begin DoDot:6
+35 IF $Y>(IOSL-5)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO HEAD
+36 WRITE ?30,$EXTRACT($$USER^PRCPUREP(USER),1,30),!
+37 if $DATA(PRCPFLAG)
QUIT
End DoDot:6
+38 if $DATA(PRCPFLAG)
QUIT
End DoDot:5
if $DATA(PRCPFLAG)
QUIT
+39 if $DATA(PRCPFLAG)
QUIT
End DoDot:4
+40 if $DATA(PRCPFLAG)
QUIT
End DoDot:3
if $DATA(PRCPFLAG)
QUIT
+41 if $DATA(PRCPFLAG)
QUIT
+42 ;Display secondary authorized users
+43 SET SECNAME=$PIECE($GET(^PRCP(445,SEC,0)),"^",1)
+44 WRITE !,$EXTRACT(SECNAME,1,28),":"
+45 SET USER=0
FOR
SET USER=$ORDER(^PRCP(445,SEC,4,USER))
if USER=""
QUIT
Begin DoDot:3
+46 SET MGRFLG=""
+47 IF $GET(^PRCP(445,SEC,9,0))'=""
Begin DoDot:4
+48 SET ODIUSER=0
+49 FOR
SET ODIUSER=$ORDER(^PRCP(445,SEC,9,ODIUSER))
if +ODIUSER=0
QUIT
Begin DoDot:5
+50 IF $GET(^PRCP(445,SEC,9,ODIUSER,0))=USER
Begin DoDot:6
+51 IF $Y>(IOSL-5)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO HEAD
+52 WRITE ?30,$EXTRACT($$USER^PRCPUREP(USER),1,30),!
+53 if $DATA(PRCPFLAG)
QUIT
End DoDot:6
+54 if $DATA(PRCPFLAG)
QUIT
End DoDot:5
if $DATA(PRCPFLAG)
QUIT
+55 if $DATA(PRCPFLAG)
QUIT
End DoDot:4
+56 if $DATA(PRCPFLAG)
QUIT
End DoDot:3
if $DATA(PRCPFLAG)
QUIT
+57 if $DATA(PRCPFLAG)
QUIT
End DoDot:2
if $DATA(PRCPFLAG)
QUIT
+58 if $DATA(PRCPFLAG)
QUIT
End DoDot:1
if $DATA(PRCPFLAG)
QUIT
+59 IF RECCNT=0
DO HEAD2
WRITE !,?27,"*** NO CONFLICTS TO PRINT ***",!
+60 DO END^PRCPUREP
+61 DO Q
QUIT
+62 ;
DISPL ; Display the information about the secondaries
+1 SET DISTR=""
FOR J=1:1
SET DISTR=$ORDER(DISPT(PRCP("I"),DISTR))
if DISTR=""
QUIT
Begin DoDot:1
+2 WRITE !,?1,DISTR,?6,$PIECE(DISPT(PRCP("I"),DISTR),"^",1),?8,$PIECE(DISPT(PRCP("I"),DISTR),"^",2)
End DoDot:1
+3 QUIT
FILL SET DISTR=""
FOR I=1:1
SET DISTR=$ORDER(DISPT(PRCP("I"),DISTR))
if DISTR=""
QUIT
SET $PIECE(DISPT(PRCP("I"),DISTR),"^",1)="*"
+1 QUIT
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),?48,%
+5 WRITE !,"PRIMARY INVENTORY POINT: ",PRIM(PRI)
+6 WRITE !!,"IM#",?11,"DESCRIPTION"
+7 SET %=""
SET $PIECE(%,"-",80)=""
WRITE !,%,!
+8 KILL PRCPFLAG
+9 QUIT
HEAD2 SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE !,"ON-DEMAND CONFLICT REPORT",?48,%
+2 WRITE !,"PRIMARY INVENTORY POINT: ",PRIM(PRI)
+3 WRITE !!,"IM#",?11,"DESCRIPTION"
+4 SET %=""
SET $PIECE(%,"-",80)=""
WRITE !,%,!
+5 QUIT
Q DO ^%ZISC
KILL ^TMP($JOB,"PRIM"),^TMP($JOB,"SEC"),^TMP($JOB,"COMB")
+1 QUIT
