source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRODM.m@ 1755

Last change on this file since 1755 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 7.3 KB
Line 
1PRCPRODM ;WOIFO/CC/VAC-On-Demand Conflict Report ; 2/21/07 11:22am
2 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;*98 Created to identify items in Primary as ODI but not in Secondary
5 Q
6PRIM I $G(PRCP("DPTYPE"))="S" D PRIM^PRCPRODS Q
7 N CHOICE,CTR,DATA2,DATA3,DISFLG,DISPT,DISTR,GROUP,GROUPALL,GROUPNM,I,IT,ITEM,ITEMNM,ITNAME,J
8 N LST,MGRFLG,NOW,NOWDT,ODITEM,ODIUSER,ORD,PAGE,PRCPFLAG,PRI,PRIM,SCREEN,SEC,SECNAME,SRT,USER,X,Y,MAN,RECCNT,GR,GROUPYES
9 N POP,ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE
10 K ^TMP($J,"PRIM"),^TMP($J,"SEC"),^TMP($J,"COMB")
11 S PAGE=1
12 D NOW^%DTC S NOWDT=X,Y=% D DD^%DT S NOW=Y,SCREEN=$$SCRPAUSE^PRCPUREP
13 D ^PRCPUSEL Q:'$G(PRCP("I"))
14 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)
15 S CTR=$P($G(^PRCP(445,PRCP("I"),2,0)),"^",4)
16 I +CTR=0 W !,"NO DISTRIBUTION POINTS EXIST FOR THIS PRIMARY" HANG 5 Q
17 S DISTR=0 F I=1:1:CTR S DISTR=$O(^PRCP(445,PRCP("I"),2,DISTR)) Q:'DISTR!($G(PRCPFLAG)) D
18 .S $P(DISPT(PRCP("I"),DISTR),"^",2)=$$INVNAME^PRCPUX1(DISTR)
19QUEST0 ;
20 K X S X(1)="Select the DISTRIBUTION POINTS to display" D DISPLAY^PRCPUX2(2,40,.X)
21 D DISTRSEL^PRCPURS3(PRCP("I"))
22QUEST1 ;
23 S DISFLG=""
24 I $D(^TMP($J,"PRCPURS3","YES"))=0 D FILL G QUEST3
25 S X="" F S X=$O(^TMP($J,"PRCPURS3","YES",X)) Q:X="" D
26 . S $P(DISPT(PRCP("I"),X),"^",1)="*"
27QUEST3 ; Select Groups
28 S DISTR=""
29 F S DISTR=$O(DISPT(PRCP("I"),DISTR)) Q:DISTR="" D
30 .I $P(DISPT(PRCP("I"),DISTR),"^",1)["*" S DISFLG="Y"
31 I DISFLG="" W !,"No Distribution Points picked. Try again." HANG 5 G QUEST0
32 K X S X(1)="Select the Group Categories to display" D DISPLAY^PRCPUX2(2,40,.X)
33 D GROUPSEL^PRCPURS1(PRCP("I"))
34 I '$G(GROUPALL),'$O(^TMP($J,"PRCPURS1","YES",0)) W !,"*** NO GROUP CATEGORIES SELECTED !" D Q Q
35 W !,"NOTE: The report will",$S('$G(GROUPALL):" NOT",1:"")," include items not stored in a group category."
36QUEST4 ; Select Sort order
37 K X S X(1)="Select the order in which you want the item information to appear." D DISPLAY^PRCPUX2(2,40,.X)
38 S SRT=$$SRTPRMP^PRCPUX2(0)
39 Q:SRT=0
40 S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK D ^%ZISC Q
41 . S ZTDESC="On-Demand Conflict Report",ZTRTN="REPORT^PRCPRODM"
42 . S ZTSAVE("S*")="",ZTSAVE("PRCP*")="",ZTSAVE("GR*")="",ZTSAVE("D*")="",ZTSAVE("P*")="",ZTSAVE("C*")="",ZTSAVE("I*")="",ZTSAVE("N*")=""
43 . S ZTSAVE("^TMP($J,""PRCPURS3"",")="",ZTSAVE("O*")="",ZTSAVE("U*")=""
44 ;
45QUEST5 W !!,"Please wait. Report compiling and printing."
46REPORT ;Now compile the data
47 S PRI=PRCP("I")
48 S PRIM(PRI)=$P(PRCP("PAR"),"^",1)
49 S ITEM=0 F I=1:1 S ITEM=$O(^PRCP(445,PRI,1,ITEM)) Q:+ITEM=0 D
50 .S ODITEM=$$ODITEM^PRCPUX2(PRI,ITEM)
51 .I ODITEM'="Y" Q
52 .S ^TMP($J,"PRIM",ITEM)=$$DESCR^PRCPUX1(PRI,ITEM)
53 .S:^TMP($J,"PRIM",ITEM)="" ^TMP($J,"PRIM",ITEM)=" "
54 ;Now get items in secondaries that match
55 S DISTR="" F I=1:1 S DISTR=$O(DISPT(PRI,DISTR)) Q:DISTR="" D
56 .Q:$P($G(DISPT(PRI,DISTR)),"^",1)'="*"
57 .S ITEM=0 F J=1:1 S ITEM=$O(^TMP($J,"PRIM",ITEM)) Q:+ITEM=0 D
58 ..Q:$G(^PRCP(445,DISTR,1,ITEM,0))=""
59 ..S ODITEM=$$ODITEM^PRCPUX2(DISTR,ITEM)
60 ..S MAN=$P($G(^PRCP(445,DISTR,1,ITEM,0)),"^",12)
61 ..I PRI'=$P(MAN,";",1) Q
62 ..I ODITEM="Y" Q
63 ..S $P(^TMP($J,"SEC",DISTR,ITEM),"^",1)=^TMP($J,"PRIM",ITEM)
64 ; Now put in order by group and sort sequence
65 S DISTR="" F S DISTR=$O(^TMP($J,"SEC",DISTR)) Q:DISTR="" D
66 .S ITEM="" F S ITEM=$O(^TMP($J,"SEC",DISTR,ITEM)) Q:ITEM="" D
67 ..S DATA2=$G(^PRCP(445,PRI,1,ITEM,0))
68 ..Q:DATA2=""
69 ..S GROUP=+$P(DATA2,"^",21)
70 ..;Determine if the item is in the group
71 ..S GROUPYES="YES"
72 ..I $G(GROUPALL)="" S GROUPYES="NO" D
73 ...S GR="" F S GR=$O(^TMP($J,"PRCPURS1","YES",GR)) Q:GR="" D
74 ....I GR=GROUP S GROUPYES="YES"
75 ..Q:GROUPYES="NO"
76 ..S GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
77 ..I GROUPNM'="" S GROUP=$P(GROUPNM,":",2)
78 ..I GROUPNM="" S GROUP=+GROUPNM
79 ..S ITEMNM=$P($G(^TMP($J,"SEC",DISTR,ITEM)),"^",1)
80 ..S ORD=ITEM
81 ..I SRT=1 S ORD=ITEMNM
82 ..S ^TMP($J,"COMB",PRI,DISTR,GROUP,ORD)=ITEM_"^"_ITEMNM
83REP ;Now print the report
84 S PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO
85 S RECCNT=0
86 S PRIM="" F S PRIM=$O(^TMP($J,"COMB",PRIM)) Q:PRIM="" D Q:$D(PRCPFLAG)
87 .S SEC="" F S SEC=$O(^TMP($J,"COMB",PRIM,SEC)) Q:SEC="" D Q:$D(PRCPFLAG)
88 ..D:PAGE>1&SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
89 ..S GROUP="" F S GROUP=$O(^TMP($J,"COMB",PRIM,SEC,GROUP)) Q:GROUP="" D Q:$D(PRCPFLAG)
90 ...I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
91 ...Q:$D(PRCPFLAG)
92 ...I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !,?10,"<<<TASKMANAGER JOB TERMINATED BY USER >>>"
93 ...W !,"GROUP: " I GROUP'=0 W GROUP,!
94 ...I GROUP=0 W "<<NONE>>",!
95 ...S ORD="" F S ORD=$O(^TMP($J,"COMB",PRIM,SEC,GROUP,ORD)) Q:ORD="" D Q:$D(PRCPFLAG)
96 ....S DATA3=$G(^TMP($J,"COMB",PRIM,SEC,GROUP,ORD))
97 ....S IT=$P(DATA3,"^",1),ITNAME=$P(DATA3,"^",2)
98 ....S RECCNT=RECCNT+1
99 ....I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
100 ....Q:$D(PRCPFLAG)
101 ....I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
102 ....Q:$D(PRCPFLAG)
103 ....W ?1,IT,?11,ITNAME,!
104 ...Q:$D(PRCPFLAG)
105 ..Q:$D(PRCPFLAG)
106 ..; Print authorized users
107 ..I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
108 ..W !!,"AUTHORIZED ON-DEMAND USERS"
109 ..W !,"--------------------------",!
110 ..; I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
111 ..W PRIM(PRI),":"
112 ..S USER=0 F S USER=$O(^PRCP(445,PRI,4,USER)) Q:USER="" D Q:$D(PRCPFLAG)
113 ...S MGRFLG=""
114 ...I $G(^PRCP(445,PRI,9,0))'="" D
115 ....S LST=$P($G(^PRCP(445,PRI,9,0)),"^",4)
116 ....S ODIUSER=0 F S ODIUSER=$O(^PRCP(445,PRI,9,ODIUSER)) Q:+ODIUSER=0 D Q:$D(PRCPFLAG)
117 .....I $G(^PRCP(445,PRI,9,ODIUSER,0))=USER D
118 ......I $Y>(IOSL-5) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
119 ......W ?30,$E($$USER^PRCPUREP(USER),1,30),!
120 ......Q:$D(PRCPFLAG)
121 .....Q:$D(PRCPFLAG)
122 ....Q:$D(PRCPFLAG)
123 ...Q:$D(PRCPFLAG)
124 ..Q:$D(PRCPFLAG)
125 ..;Display secondary authorized users
126 ..S SECNAME=$P($G(^PRCP(445,SEC,0)),"^",1)
127 ..W !,$E(SECNAME,1,28),":"
128 ..S USER=0 F S USER=$O(^PRCP(445,SEC,4,USER)) Q:USER="" D Q:$D(PRCPFLAG)
129 ...S MGRFLG=""
130 ...I $G(^PRCP(445,SEC,9,0))'="" D
131 ....S ODIUSER=0
132 ....F S ODIUSER=$O(^PRCP(445,SEC,9,ODIUSER)) Q:+ODIUSER=0 D Q:$D(PRCPFLAG)
133 .....I $G(^PRCP(445,SEC,9,ODIUSER,0))=USER D
134 ......I $Y>(IOSL-5) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
135 ......W ?30,$E($$USER^PRCPUREP(USER),1,30),!
136 ......Q:$D(PRCPFLAG)
137 .....Q:$D(PRCPFLAG)
138 ....Q:$D(PRCPFLAG)
139 ...Q:$D(PRCPFLAG)
140 ..Q:$D(PRCPFLAG)
141 .Q:$D(PRCPFLAG)
142 I RECCNT=0 D HEAD2 W !,?27,"*** NO CONFLICTS TO PRINT ***",!
143 D END^PRCPUREP
144 D Q Q
145 ;
146DISPL ; Display the information about the secondaries
147 S DISTR="" F J=1:1 S DISTR=$O(DISPT(PRCP("I"),DISTR)) Q:DISTR="" D
148 . W !,?1,DISTR,?6,$P(DISPT(PRCP("I"),DISTR),"^",1),?8,$P(DISPT(PRCP("I"),DISTR),"^",2)
149 Q
150FILL S DISTR="" F I=1:1 S DISTR=$O(DISPT(PRCP("I"),DISTR)) Q:DISTR="" S $P(DISPT(PRCP("I"),DISTR),"^",1)="*"
151 Q
152HEAD ;Display header information
153 Q:$D(PRCPFLAG)
154 S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
155 S SECNAME=$P($G(^PRCP(445,SEC,0)),"^",1)
156 W !,"ON-DEMAND CONFLICTS IN: ",$E(SECNAME,1,24),?48,%
157 W !,"PRIMARY INVENTORY POINT: ",PRIM(PRI)
158 W !!,"IM#",?11,"DESCRIPTION"
159 S %="",$P(%,"-",80)="" W !,%,!
160 K PRCPFLAG
161 Q
162HEAD2 S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
163 W !,"ON-DEMAND CONFLICT REPORT",?48,%
164 W !,"PRIMARY INVENTORY POINT: ",PRIM(PRI)
165 W !!,"IM#",?11,"DESCRIPTION"
166 S %="",$P(%,"-",80)="" W !,%,!
167 Q
168Q D ^%ZISC K ^TMP($J,"PRIM"),^TMP($J,"SEC"),^TMP($J,"COMB")
169 Q
Note: See TracBrowser for help on using the repository browser.