- 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 Jan 18, 2025@03:16:22 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