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

PRCPRODS.m

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