source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRODS.m@ 1350

PRCPRODS ;WOIFO/CC/VAC-On-Demand Conflict Report Secondary ; 2/22/07 9:38am
 ;;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 Secondary as ODI but not in Primary
 Q
PRIM N CTR,I,ITEM,ITEMNAM,J,SECNAME,TOTREC
 N LST,MGRFLG,NOW,NOWDT,PAGE,PRCPFLAG,PRI,PRIM,SCREEN,SEC,SECNAME,SRT,SORT,USER,X,Y,RECCNT,ODIFLAG,ODIFLAG2,PRINAME
 N POP,ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE
 D ^PRCPUSEL Q:'$G(PRCP("I"))
 K ^TMP($J,"PRCPRODS")
 S PAGE=1
 D NOW^%DTC S NOWDT=X,Y=% D DD^%DT S NOW=Y,SCREEN=$$SCRPAUSE^PRCPUREP
 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=0
 S X="" F  S X=$O(^PRCP(445,PRCP("I"),1,"AC",X)) Q:X=""  S CTR=CTR+1
 I +CTR=0 W !,"NO PRIMARY CROSS REFERENCES EXIST FOR THIS SECONDARY" HANG 5 Q
QUEST ; Select Sort order
 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 Q
 .S ZTDESC="On Demand Conflict Report",ZTRTN="REPORT^PRCPRODS"
 .S ZTSAVE("PRCP*")="",ZTSAVE("REPTYPE")="",ZTSAVE("S*")="",ZTSAVE("END*")="",ZTSAVE("NOW*")="",ZTSAVE("COMDT")="",ZTSAVE("PERCENT")="",ZTSAVE("REP")="",ZTSAVE("ZTREQ")="@"
 .S ZTSAVE("S*")="",ZTSAVE("C*")=""
 ;
QUEST2 W !!,"Please wait.  Report compiling and printing."
REPORT ;Now compile the data
 S PRIM=""
 S PRI="" F  S PRI=$O(^PRCP(445,PRCP("I"),1,"AC",PRI)) Q:PRI=""  D
 .I PRIM="" S PRIM=$P(PRI,";",1)
 .I PRIM'=$P(PRI,";",1) D
 .. S PRIM=$P(PRI,";",1)
 .S ITEM=""
 .F  S ITEM=$O(^PRCP(445,PRCP("I"),1,"AC",PRI,ITEM)) Q:ITEM=""  D
 ..S ODIFLAG=$$ODITEM^PRCPUX2(PRCP("I"),ITEM)
 ..S ODIFLAG2=$$ODITEM^PRCPUX2(PRIM,ITEM)
 ..;S ITEMNAM=$P($G(^PRCP(445,PRCP("I"),1,ITEM,6)),"^",1)
 ..S ITEMNAM=$$DESCR^PRCPUX1(PRCP("I"),ITEM) S:ITEMNAM="" ITEMNAM=" "
 ..S SORT=ITEMNAM
 ..I SRT=2 S SORT=ITEM
 ..I ODIFLAG2="Y" D
 ...I (ODIFLAG="N")!(ODIFLAG="") D
 ....S ^TMP($J,"PRCPRODS",PRCP("I"),PRIM,SORT,ITEM)=ITEMNAM
RPT ;Now print the report
 S PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO
 S TOTREC=0
 S SEC=""
 F  S SEC=$O(^TMP($J,"PRCPRODS",SEC)) Q:SEC=""  D  Q:$D(PRCPFLAG)
 .S PRIM=""
 .F  S PRIM=$O(^TMP($J,"PRCPRODS",SEC,PRIM)) Q:PRIM=""  D  Q:$D(PRCPFLAG)
 ..S PRINAME=$P($G(^PRCP(445,PRIM,0)),"^",1)
 ..D:PAGE>1&SCREEN P^PRCPUREP Q:$D(PRCPFLAG)  D HEAD
 ..S RECCNT=0
 ..S SORT=""
 ..F  S SORT=$O(^TMP($J,"PRCPRODS",SEC,PRIM,SORT)) Q:SORT=""  D  Q:$D(PRCPFLAG)
 ...S ITEM=""
 ...F  S ITEM=$O(^TMP($J,"PRCPRODS",SEC,PRIM,SORT,ITEM)) Q:ITEM=""  D  Q:$D(PRCPFLAG)
 ....S ITEMNAM=$G(^TMP($J,"PRCPRODS",SEC,PRIM,SORT,ITEM))
 ....W !,ITEM,?11,ITEMNAM
 ....S RECCNT=RECCNT+1,TOTREC=TOTREC+1
 ....I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG)  D HEAD
 ....I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !,?10,"<<<TASKMANAGER JOB TERMINATED BY USER >>>" Q
 ...I RECCNT=0 W !,"No Records Found",!
 ...Q
 ..I '$D(PRCPFLAG) D A
 .Q
 ;
 I TOTREC=0 D HEAD2 W !?27,"*** NO CONFLICTS TO PRINT ***"
 I '$D(PRCPFLAG) D:SCREEN END^PRCPUREP
 D ^%ZISC
 D Q Q
 ;
A ; Print authorized users
 I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG)  D HEAD
 S SECNAME=$P($G(^PRCP(445,SEC,0)),"^",1)
 W !!,"AUTHORIZED ON-DEMAND USERS"
 W !,"--------------------------"
 W !,SECNAME,":"
 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 LST=$P($G(^PRCP(445,SEC,9,0)),"^",4)
 ..S J=0
 ..F I=1:1:LST D  Q:$D(PRCPFLAG)
 ...S J=$O(^PRCP(445,SEC,9,J))
 ...I $G(^PRCP(445,SEC,9,J,0))=USER D
 ....I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG)  D HEAD
 ....I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
 ....Q:$D(PRCPFLAG)
 ....W ?30,$E($$USER^PRCPUREP(USER),1,30),!
 ...Q:$D(PRCPFLAG)
 ..Q:$D(PRCPFLAG)
 .Q:$D(PRCPFLAG)
 D B
 Q
B ; Display Primary authorized users
 I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG)  D HEAD
 S PRINAME=$P($G(^PRCP(445,PRIM,0)),"^",1)
 W !
 W $E(PRINAME,1,28),":"
 S USER=0 F  S USER=$O(^PRCP(445,PRIM,4,USER)) Q:USER=""  D  Q:$D(PRCPFLAG)
 .S MGRFLG=""
 .I $G(^PRCP(445,PRIM,9,0))'="" D
 ..S LST=$P($G(^PRCP(445,PRIM,9,0)),"^",4)
 ..S J=0
 ..F I=1:1:LST D  Q:$D(PRCPFLAG)
 ...S J=$O(^PRCP(445,PRIM,9,J))
 ...I $G(^PRCP(445,PRIM,9,J,0))=USER D  Q:$D(PRCPFLAG)
 ....I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG)  D HEAD
 ....I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<<TASKMANAGER JOB TERMINATED BY USER >>>" Q
 ....W ?30,$E($$USER^PRCPUREP(USER),1,30),!
 ...Q:$D(PRCPFLAG)
 ..Q:$D(PRCPFLAG)
 .Q:$D(PRCPFLAG)
 Q:$D(PRCPFLAG)
 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),?50,%
 W !,"PRIMARY INVENTORY POINT: ",PRINAME
 W !!,"IM#",?11,"DESCRIPTION"
 S %="",$P(%,"-",80)="" W !,%,!
 Q
HEAD2 ;Display header if no records found
 S %=NOW_"  PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
 W !,"SECONDARY ON-DEMAND CONFLICT REPORT",?50,%
 W !!,"IM#",?11,"DESCRIPTION"
 S %="",$P(%,"-",80)="" W !,%,!
 Q
Q K ^TMP($J,"PRCPRODS")
 Q