source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRODS.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 5.0 KB
Line 
1PRCPRODS ;WOIFO/CC/VAC-On-Demand Conflict Report Secondary ; 2/22/07 9:38am
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 Secondary as ODI but not in Primary
5 Q
6PRIM N CTR,I,ITEM,ITEMNAM,J,SECNAME,TOTREC
7 N LST,MGRFLG,NOW,NOWDT,PAGE,PRCPFLAG,PRI,PRIM,SCREEN,SEC,SECNAME,SRT,SORT,USER,X,Y,RECCNT,ODIFLAG,ODIFLAG2,PRINAME
8 N POP,ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE
9 D ^PRCPUSEL Q:'$G(PRCP("I"))
10 K ^TMP($J,"PRCPRODS")
11 S PAGE=1
12 D NOW^%DTC S NOWDT=X,Y=% D DD^%DT S NOW=Y,SCREEN=$$SCRPAUSE^PRCPUREP
13 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)
14 S CTR=0
15 S X="" F S X=$O(^PRCP(445,PRCP("I"),1,"AC",X)) Q:X="" S CTR=CTR+1
16 I +CTR=0 W !,"NO PRIMARY CROSS REFERENCES EXIST FOR THIS SECONDARY" HANG 5 Q
17QUEST ; Select Sort order
18 S SRT=$$SRTPRMP^PRCPUX2(0)
19 Q:SRT=0
20 S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
21 .S ZTDESC="On Demand Conflict Report",ZTRTN="REPORT^PRCPRODS"
22 .S ZTSAVE("PRCP*")="",ZTSAVE("REPTYPE")="",ZTSAVE("S*")="",ZTSAVE("END*")="",ZTSAVE("NOW*")="",ZTSAVE("COMDT")="",ZTSAVE("PERCENT")="",ZTSAVE("REP")="",ZTSAVE("ZTREQ")="@"
23 .S ZTSAVE("S*")="",ZTSAVE("C*")=""
24 ;
25QUEST2 W !!,"Please wait. Report compiling and printing."
26REPORT ;Now compile the data
27 S PRIM=""
28 S PRI="" F S PRI=$O(^PRCP(445,PRCP("I"),1,"AC",PRI)) Q:PRI="" D
29 .I PRIM="" S PRIM=$P(PRI,";",1)
30 .I PRIM'=$P(PRI,";",1) D
31 .. S PRIM=$P(PRI,";",1)
32 .S ITEM=""
33 .F S ITEM=$O(^PRCP(445,PRCP("I"),1,"AC",PRI,ITEM)) Q:ITEM="" D
34 ..S ODIFLAG=$$ODITEM^PRCPUX2(PRCP("I"),ITEM)
35 ..S ODIFLAG2=$$ODITEM^PRCPUX2(PRIM,ITEM)
36 ..;S ITEMNAM=$P($G(^PRCP(445,PRCP("I"),1,ITEM,6)),"^",1)
37 ..S ITEMNAM=$$DESCR^PRCPUX1(PRCP("I"),ITEM) S:ITEMNAM="" ITEMNAM=" "
38 ..S SORT=ITEMNAM
39 ..I SRT=2 S SORT=ITEM
40 ..I ODIFLAG2="Y" D
41 ...I (ODIFLAG="N")!(ODIFLAG="") D
42 ....S ^TMP($J,"PRCPRODS",PRCP("I"),PRIM,SORT,ITEM)=ITEMNAM
43RPT ;Now print the report
44 S PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO
45 S TOTREC=0
46 S SEC=""
47 F S SEC=$O(^TMP($J,"PRCPRODS",SEC)) Q:SEC="" D Q:$D(PRCPFLAG)
48 .S PRIM=""
49 .F S PRIM=$O(^TMP($J,"PRCPRODS",SEC,PRIM)) Q:PRIM="" D Q:$D(PRCPFLAG)
50 ..S PRINAME=$P($G(^PRCP(445,PRIM,0)),"^",1)
51 ..D:PAGE>1&SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
52 ..S RECCNT=0
53 ..S SORT=""
54 ..F S SORT=$O(^TMP($J,"PRCPRODS",SEC,PRIM,SORT)) Q:SORT="" D Q:$D(PRCPFLAG)
55 ...S ITEM=""
56 ...F S ITEM=$O(^TMP($J,"PRCPRODS",SEC,PRIM,SORT,ITEM)) Q:ITEM="" D Q:$D(PRCPFLAG)
57 ....S ITEMNAM=$G(^TMP($J,"PRCPRODS",SEC,PRIM,SORT,ITEM))
58 ....W !,ITEM,?11,ITEMNAM
59 ....S RECCNT=RECCNT+1,TOTREC=TOTREC+1
60 ....I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
61 ....I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !,?10,"<<<TASKMANAGER JOB TERMINATED BY USER >>>" Q
62 ...I RECCNT=0 W !,"No Records Found",!
63 ...Q
64 ..I '$D(PRCPFLAG) D A
65 .Q
66 ;
67 I TOTREC=0 D HEAD2 W !?27,"*** NO CONFLICTS TO PRINT ***"
68 I '$D(PRCPFLAG) D:SCREEN END^PRCPUREP
69 D ^%ZISC
70 D Q Q
71 ;
72A ; Print authorized users
73 I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
74 S SECNAME=$P($G(^PRCP(445,SEC,0)),"^",1)
75 W !!,"AUTHORIZED ON-DEMAND USERS"
76 W !,"--------------------------"
77 W !,SECNAME,":"
78 S USER=0 F S USER=$O(^PRCP(445,SEC,4,USER)) Q:USER="" D Q:$D(PRCPFLAG)
79 .S MGRFLG=""
80 .I $G(^PRCP(445,SEC,9,0))'="" D
81 ..S LST=$P($G(^PRCP(445,SEC,9,0)),"^",4)
82 ..S J=0
83 ..F I=1:1:LST D Q:$D(PRCPFLAG)
84 ...S J=$O(^PRCP(445,SEC,9,J))
85 ...I $G(^PRCP(445,SEC,9,J,0))=USER D
86 ....I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
87 ....I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
88 ....Q:$D(PRCPFLAG)
89 ....W ?30,$E($$USER^PRCPUREP(USER),1,30),!
90 ...Q:$D(PRCPFLAG)
91 ..Q:$D(PRCPFLAG)
92 .Q:$D(PRCPFLAG)
93 D B
94 Q
95B ; Display Primary authorized users
96 I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
97 S PRINAME=$P($G(^PRCP(445,PRIM,0)),"^",1)
98 W !
99 W $E(PRINAME,1,28),":"
100 S USER=0 F S USER=$O(^PRCP(445,PRIM,4,USER)) Q:USER="" D Q:$D(PRCPFLAG)
101 .S MGRFLG=""
102 .I $G(^PRCP(445,PRIM,9,0))'="" D
103 ..S LST=$P($G(^PRCP(445,PRIM,9,0)),"^",4)
104 ..S J=0
105 ..F I=1:1:LST D Q:$D(PRCPFLAG)
106 ...S J=$O(^PRCP(445,PRIM,9,J))
107 ...I $G(^PRCP(445,PRIM,9,J,0))=USER D Q:$D(PRCPFLAG)
108 ....I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D HEAD
109 ....I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<<TASKMANAGER JOB TERMINATED BY USER >>>" Q
110 ....W ?30,$E($$USER^PRCPUREP(USER),1,30),!
111 ...Q:$D(PRCPFLAG)
112 ..Q:$D(PRCPFLAG)
113 .Q:$D(PRCPFLAG)
114 Q:$D(PRCPFLAG)
115 Q
116 ;
117HEAD ;Display header information
118 Q:$D(PRCPFLAG)
119 S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
120 S SECNAME=$P($G(^PRCP(445,SEC,0)),"^",1)
121 W !,"ON-DEMAND CONFLICTS IN: ",$E(SECNAME,1,24),?50,%
122 W !,"PRIMARY INVENTORY POINT: ",PRINAME
123 W !!,"IM#",?11,"DESCRIPTION"
124 S %="",$P(%,"-",80)="" W !,%,!
125 Q
126HEAD2 ;Display header if no records found
127 S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
128 W !,"SECONDARY ON-DEMAND CONFLICT REPORT",?50,%
129 W !!,"IM#",?11,"DESCRIPTION"
130 S %="",$P(%,"-",80)="" W !,%,!
131 Q
132Q K ^TMP($J,"PRCPRODS")
133 Q
Note: See TracBrowser for help on using the repository browser.