Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPRODM

PRCPRODM.m

Go to the documentation of this file.
  1. PRCPRODM ;WOIFO/CC/VAC-On-Demand Conflict Report ; 2/21/07 11:22am
  1. ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;*98 Created to identify items in Primary as ODI but not in Secondary
  1. Q
  1. PRIM I $G(PRCP("DPTYPE"))="S" D PRIM^PRCPRODS Q
  1. N CHOICE,CTR,DATA2,DATA3,DISFLG,DISPT,DISTR,GROUP,GROUPALL,GROUPNM,I,IT,ITEM,ITEMNM,ITNAME,J
  1. N LST,MGRFLG,NOW,NOWDT,ODITEM,ODIUSER,ORD,PAGE,PRCPFLAG,PRI,PRIM,SCREEN,SEC,SECNAME,SRT,USER,X,Y,MAN,RECCNT,GR,GROUPYES
  1. N POP,ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE
  1. K ^TMP($J,"PRIM"),^TMP($J,"SEC"),^TMP($J,"COMB")
  1. S PAGE=1
  1. D NOW^%DTC S NOWDT=X,Y=% D DD^%DT S NOW=Y,SCREEN=$$SCRPAUSE^PRCPUREP
  1. D ^PRCPUSEL Q:'$G(PRCP("I"))
  1. 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)
  1. S CTR=$P($G(^PRCP(445,PRCP("I"),2,0)),"^",4)
  1. I +CTR=0 W !,"NO DISTRIBUTION POINTS EXIST FOR THIS PRIMARY" HANG 5 Q
  1. S DISTR=0 F I=1:1:CTR S DISTR=$O(^PRCP(445,PRCP("I"),2,DISTR)) Q:'DISTR!($G(PRCPFLAG)) D
  1. .S $P(DISPT(PRCP("I"),DISTR),"^",2)=$$INVNAME^PRCPUX1(DISTR)
  1. QUEST0 ;
  1. K X S X(1)="Select the DISTRIBUTION POINTS to display" D DISPLAY^PRCPUX2(2,40,.X)
  1. D DISTRSEL^PRCPURS3(PRCP("I"))
  1. QUEST1 ;
  1. S DISFLG=""
  1. I $D(^TMP($J,"PRCPURS3","YES"))=0 D FILL G QUEST3
  1. S X="" F S X=$O(^TMP($J,"PRCPURS3","YES",X)) Q:X="" D
  1. . S $P(DISPT(PRCP("I"),X),"^",1)="*"
  1. QUEST3 ; Select Groups
  1. S DISTR=""
  1. F S DISTR=$O(DISPT(PRCP("I"),DISTR)) Q:DISTR="" D
  1. .I $P(DISPT(PRCP("I"),DISTR),"^",1)["*" S DISFLG="Y"
  1. I DISFLG="" W !,"No Distribution Points picked. Try again." HANG 5 G QUEST0
  1. K X S X(1)="Select the Group Categories to display" D DISPLAY^PRCPUX2(2,40,.X)
  1. D GROUPSEL^PRCPURS1(PRCP("I"))
  1. I '$G(GROUPALL),'$O(^TMP($J,"PRCPURS1","YES",0)) W !,"*** NO GROUP CATEGORIES SELECTED !" D Q Q
  1. W !,"NOTE: The report will",$S('$G(GROUPALL):" NOT",1:"")," include items not stored in a group category."
  1. QUEST4 ; Select Sort order
  1. K X S X(1)="Select the order in which you want the item information to appear." D DISPLAY^PRCPUX2(2,40,.X)
  1. S SRT=$$SRTPRMP^PRCPUX2(0)
  1. Q:SRT=0
  1. S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK D ^%ZISC Q
  1. . S ZTDESC="On-Demand Conflict Report",ZTRTN="REPORT^PRCPRODM"
  1. . S ZTSAVE("S*")="",ZTSAVE("PRCP*")="",ZTSAVE("GR*")="",ZTSAVE("D*")="",ZTSAVE("P*")="",ZTSAVE("C*")="",ZTSAVE("I*")="",ZTSAVE("N*")=""
  1. . S ZTSAVE("^TMP($J,""PRCPURS3"",")="",ZTSAVE("O*")="",ZTSAVE("U*")=""
  1. ;
  1. QUEST5 W !!,"Please wait. Report compiling and printing."
  1. REPORT ;Now compile the data
  1. S PRI=PRCP("I")
  1. S PRIM(PRI)=$P(PRCP("PAR"),"^",1)
  1. S ITEM=0 F I=1:1 S ITEM=$O(^PRCP(445,PRI,1,ITEM)) Q:+ITEM=0 D
  1. .S ODITEM=$$ODITEM^PRCPUX2(PRI,ITEM)
  1. .I ODITEM'="Y" Q
  1. .S ^TMP($J,"PRIM",ITEM)=$$DESCR^PRCPUX1(PRI,ITEM)
  1. .S:^TMP($J,"PRIM",ITEM)="" ^TMP($J,"PRIM",ITEM)=" "
  1. ;Now get items in secondaries that match
  1. S DISTR="" F I=1:1 S DISTR=$O(DISPT(PRI,DISTR)) Q:DISTR="" D
  1. .Q:$P($G(DISPT(PRI,DISTR)),"^",1)'="*"
  1. .S ITEM=0 F J=1:1 S ITEM=$O(^TMP($J,"PRIM",ITEM)) Q:+ITEM=0 D
  1. ..Q:$G(^PRCP(445,DISTR,1,ITEM,0))=""
  1. ..S ODITEM=$$ODITEM^PRCPUX2(DISTR,ITEM)
  1. ..S MAN=$P($G(^PRCP(445,DISTR,1,ITEM,0)),"^",12)
  1. ..I PRI'=$P(MAN,";",1) Q
  1. ..I ODITEM="Y" Q
  1. ..S $P(^TMP($J,"SEC",DISTR,ITEM),"^",1)=^TMP($J,"PRIM",ITEM)
  1. ; Now put in order by group and sort sequence
  1. S DISTR="" F S DISTR=$O(^TMP($J,"SEC",DISTR)) Q:DISTR="" D
  1. .S ITEM="" F S ITEM=$O(^TMP($J,"SEC",DISTR,ITEM)) Q:ITEM="" D
  1. ..S DATA2=$G(^PRCP(445,PRI,1,ITEM,0))
  1. ..Q:DATA2=""
  1. ..S GROUP=+$P(DATA2,"^",21)
  1. ..;Determine if the item is in the group
  1. ..S GROUPYES="YES"
  1. ..I $G(GROUPALL)="" S GROUPYES="NO" D
  1. ...S GR="" F S GR=$O(^TMP($J,"PRCPURS1","YES",GR)) Q:GR="" D
  1. ....I GR=GROUP S GROUPYES="YES"
  1. ..Q:GROUPYES="NO"
  1. ..S GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
  1. ..I GROUPNM'="" S GROUP=$P(GROUPNM,":",2)
  1. ..I GROUPNM="" S GROUP=+GROUPNM
  1. ..S ITEMNM=$P($G(^TMP($J,"SEC",DISTR,ITEM)),"^",1)
  1. ..S ORD=ITEM
  1. ..I SRT=1 S ORD=ITEMNM
  1. ..S ^TMP($J,"COMB",PRI,DISTR,GROUP,ORD)=ITEM_"^"_ITEMNM
  1. REP ;Now print the report
  1. S PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO
  1. S RECCNT=0
  1. S PRIM="" F S PRIM=$O(^TMP($J,"COMB",PRIM)) Q:PRIM="" D Q:$D(PRCPFLAG)
  1. .S SEC="" F S SEC=$O(^TMP($J,"COMB",PRIM,SEC)) Q:SEC="" D Q:$D(PRCPFLAG)
  1. ..D:PAGE>1&SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
  1. ..S GROUP="" F S GROUP=$O(^TMP($J,"COMB",PRIM,SEC,GROUP)) Q:GROUP="" D Q:$D(PRCPFLAG)
  1. ...I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
  1. ...Q:$D(PRCPFLAG)
  1. ...I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !,?10,"<<<TASKMANAGER JOB TERMINATED BY USER >>>"
  1. ...W !,"GROUP: " I GROUP'=0 W GROUP,!
  1. ...I GROUP=0 W "<<NONE>>",!
  1. ...S ORD="" F S ORD=$O(^TMP($J,"COMB",PRIM,SEC,GROUP,ORD)) Q:ORD="" D Q:$D(PRCPFLAG)
  1. ....S DATA3=$G(^TMP($J,"COMB",PRIM,SEC,GROUP,ORD))
  1. ....S IT=$P(DATA3,"^",1),ITNAME=$P(DATA3,"^",2)
  1. ....S RECCNT=RECCNT+1
  1. ....I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
  1. ....Q:$D(PRCPFLAG)
  1. ....I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
  1. ....Q:$D(PRCPFLAG)
  1. ....W ?1,IT,?11,ITNAME,!
  1. ...Q:$D(PRCPFLAG)
  1. ..Q:$D(PRCPFLAG)
  1. ..; Print authorized users
  1. ..I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
  1. ..W !!,"AUTHORIZED ON-DEMAND USERS"
  1. ..W !,"--------------------------",!
  1. ..; I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
  1. ..W PRIM(PRI),":"
  1. ..S USER=0 F S USER=$O(^PRCP(445,PRI,4,USER)) Q:USER="" D Q:$D(PRCPFLAG)
  1. ...S MGRFLG=""
  1. ...I $G(^PRCP(445,PRI,9,0))'="" D
  1. ....S LST=$P($G(^PRCP(445,PRI,9,0)),"^",4)
  1. ....S ODIUSER=0 F S ODIUSER=$O(^PRCP(445,PRI,9,ODIUSER)) Q:+ODIUSER=0 D Q:$D(PRCPFLAG)
  1. .....I $G(^PRCP(445,PRI,9,ODIUSER,0))=USER D
  1. ......I $Y>(IOSL-5) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
  1. ......W ?30,$E($$USER^PRCPUREP(USER),1,30),!
  1. ......Q:$D(PRCPFLAG)
  1. .....Q:$D(PRCPFLAG)
  1. ....Q:$D(PRCPFLAG)
  1. ...Q:$D(PRCPFLAG)
  1. ..Q:$D(PRCPFLAG)
  1. ..;Display secondary authorized users
  1. ..S SECNAME=$P($G(^PRCP(445,SEC,0)),"^",1)
  1. ..W !,$E(SECNAME,1,28),":"
  1. ..S USER=0 F S USER=$O(^PRCP(445,SEC,4,USER)) Q:USER="" D Q:$D(PRCPFLAG)
  1. ...S MGRFLG=""
  1. ...I $G(^PRCP(445,SEC,9,0))'="" D
  1. ....S ODIUSER=0
  1. ....F S ODIUSER=$O(^PRCP(445,SEC,9,ODIUSER)) Q:+ODIUSER=0 D Q:$D(PRCPFLAG)
  1. .....I $G(^PRCP(445,SEC,9,ODIUSER,0))=USER D
  1. ......I $Y>(IOSL-5) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
  1. ......W ?30,$E($$USER^PRCPUREP(USER),1,30),!
  1. ......Q:$D(PRCPFLAG)
  1. .....Q:$D(PRCPFLAG)
  1. ....Q:$D(PRCPFLAG)
  1. ...Q:$D(PRCPFLAG)
  1. ..Q:$D(PRCPFLAG)
  1. .Q:$D(PRCPFLAG)
  1. I RECCNT=0 D HEAD2 W !,?27,"*** NO CONFLICTS TO PRINT ***",!
  1. D END^PRCPUREP
  1. D Q Q
  1. ;
  1. DISPL ; Display the information about the secondaries
  1. S DISTR="" F J=1:1 S DISTR=$O(DISPT(PRCP("I"),DISTR)) Q:DISTR="" D
  1. . W !,?1,DISTR,?6,$P(DISPT(PRCP("I"),DISTR),"^",1),?8,$P(DISPT(PRCP("I"),DISTR),"^",2)
  1. Q
  1. FILL S DISTR="" F I=1:1 S DISTR=$O(DISPT(PRCP("I"),DISTR)) Q:DISTR="" S $P(DISPT(PRCP("I"),DISTR),"^",1)="*"
  1. Q
  1. Q:$D(PRCPFLAG)
  1. S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
  1. S SECNAME=$P($G(^PRCP(445,SEC,0)),"^",1)
  1. W !,"ON-DEMAND CONFLICTS IN: ",$E(SECNAME,1,24),?48,%
  1. W !,"PRIMARY INVENTORY POINT: ",PRIM(PRI)
  1. W !!,"IM#",?11,"DESCRIPTION"
  1. S %="",$P(%,"-",80)="" W !,%,!
  1. K PRCPFLAG
  1. Q
  1. HEAD2 S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
  1. W !,"ON-DEMAND CONFLICT REPORT",?48,%
  1. W !,"PRIMARY INVENTORY POINT: ",PRIM(PRI)
  1. W !!,"IM#",?11,"DESCRIPTION"
  1. S %="",$P(%,"-",80)="" W !,%,!
  1. Q
  1. Q D ^%ZISC K ^TMP($J,"PRIM"),^TMP($J,"SEC"),^TMP($J,"COMB")
  1. Q