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

PRC5129.m

Go to the documentation of this file. 
  1. PRC5129 ;(WOIFO)/SU-Extract IFCAP user counts ; 04/09/2001  03:30 PM
  1. V ;;5.1;IFCAP;**29**;Oct 20, 2000
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1. POST ;
  1.  ;
  1.  NEW I,J,K,IE,FCP,DONE,STA,ESTA,IVP,LOA,LC,FDT,MGR,XMSUB,XMTEXT,XMY
  1.  NEW DIFROM
  1.  S U="^",DT=$$DT^XLFDT
  1.  K ^TMP("PRC5129")
  1. FCP ;
  1.  ;     Control Point
  1.  S I=0 F  S I=$O(^PRC(420,"C",I)) Q:'I  D
  1.  . S STA=0 F  S STA=$O(^PRC(420,"C",I,STA)) Q:'STA  D
  1.  .. S FCP=0,K=4,DONE=0
  1.  .. F  S FCP=$O(^PRC(420,"C",I,STA,FCP)) Q:'FCP!DONE  D
  1.  ... ;  skip Inactive Fund
  1.  ... I $P(^PRC(420,STA,1,FCP,0),"^",19) Q
  1.  ... ;  get control point Level Of Access
  1.  ... S LOA=$P($G(^PRC(420,STA,1,FCP,1,I,0)),"^",2)
  1.  ... I LOA>3!'LOA Q
  1.  ... I K>LOA S K=LOA   ; K only keep the highest level of access
  1.  ... I LOA=1 S DONE=1   ; Stop here if find official level
  1.  .. I K'=4 D SETP(K)
  1.  ;
  1. INV ;
  1.  ;      Inventory
  1.  ;
  1.  ;   sort user by station # through "AD",DUZ x-ref
  1.  S I=0 F  S I=$O(^PRCP(445,"AD",I)) Q:'I  D
  1.  . S IVP=0 K MGR              ;get inv pointer
  1.  . F  S IVP=$O(^PRCP(445,"AD",I,IVP)) Q:'IVP  D
  1.  .. S J=$P(^PRCP(445,IVP,0),"^",3)                ; get inv type
  1.  .. S STA=+^PRCP(445,IVP,0)                       ; get station number
  1.  .. S ^TMP("PRC5129",$J,"INV",STA,I,J)=""
  1.  ;
  1.  S STA=0 F  S STA=$O(^TMP("PRC5129",$J,"INV",STA)) Q:'STA  D
  1.  . S I=0 F  S I=$O(^TMP("PRC5129",$J,"INV",STA,I)) Q:'I  D
  1.  .. S J="" F  S J=$O(^TMP("PRC5129",$J,"INV",STA,I,J)) Q:J=""  D
  1.  ... I J="W" D                                  ; Warehouse
  1.  .... D SETP(7)                                 ;   user
  1.  .... I $D(^XUSEC("PRCPW MGRKEY",I)) D SETP(4)  ;   manager
  1.  ... I J="P" D                                  ; Primary
  1.  .... D SETP(8)                                 ;   user
  1.  .... I $D(^XUSEC("PRCP MGRKEY",I)) D SETP(5)   ;   manager
  1.  ... I J="S" D                                  ; Secondary
  1.  .... D SETP(9)                                 ;   user
  1.  .... I $D(^XUSEC("PRCP2 MGRKEY",I)) D SETP(6)  ;   manager
  1.  ;
  1. PRCH ;
  1.  ;    purchasing
  1.  ;
  1.  ;  get IFCAP primary station number   (assume only one primary)
  1.  S STA=+$O(^PRC(411,"AC","Y",0))
  1.  ;
  1.  ;  get default station for Engineering (piece 17, ^XTV(8989.3,1,"XUS"))
  1.  S ESTA=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
  1.  ;
  1.  S I=0 F  S I=$O(^VA(200,I)) Q:'I  D
  1.  . ;  Purchasing
  1.  . S J=+$G(^VA(200,I,400))
  1.  . I J,J<5 D
  1.  .. I J=1 D SETP(13)           ; Warehouse Employee
  1.  .. I J=2 D SETP(10)           ; PPM Accountable Officer
  1.  .. I J=3 D SETP(11)           ; Purchasing Agent
  1.  .. I J=4 D SETP(12)           ; Supply Manager
  1.  . ;   Engineering
  1.  . ;                Logic copied from ENZACC2 by Scott Baumann
  1.  . S K=0 I $$ACCESS^XQCHK(I,"ENINVNEW")>0 D SETE(1) S K=1
  1.  . I 'K,$$ACCESS^XQCHK(I,"ENINVINV")>0 D SETE(2) S K=1
  1.  . I $$ACCESS^XQCHK(I,"ENSPROOM")>0 D SETE(4) S K=1
  1.  . I $$ACCESS^XQCHK(I,"ENWONEW")>0 D SETE(3) S $E(K,2)=1
  1.  . I '$E(K,2),$$ACCESS^XQCHK(I,"ENWOCLOSE")>0 D SETE(3) S $E(K,2)=1
  1.  . I +K D SETE(5)
  1.  .  ; if none of the first 5 case is true or
  1.  .  ; case SETE(3) is not true but other case is true
  1.  . I ($E(K,2)'=1&+K)!'K I $$ACCESS^XQCHK(I,"ENWONEW-WARD")>0 D SETE(6)
  1.  . ; count Accounting Staff 1 time only per station
  1.  . I $D(^XUSEC("PRCFA SUPERVISOR",I)) D SETP(15) Q
  1.  . I $D(^XUSEC("PRCFA TRANSMIT",I)) D SETP(15) Q
  1.  . I $D(^XUSEC("PRCFA VENDOR EDIT",I)) D SETP(15) Q
  1.  . I $D(^XUSEC("PRCFA PURGE CODE SHEETS",I)) D SETP(15) Q
  1.  ;
  1.  ;
  1. BUDGET ;
  1.  S STA=0 F  S STA=$O(^PRC(420,STA)) Q:'STA  D
  1.  . S I=0 F  S I=$O(^PRC(420,STA,2,I)) Q:'I  D SETP(14)
  1.  ;
  1. ACNT ;
  1.  ;   Accounting
  1.  S STA=0 F  S STA=$O(^PRC(411,"AE",1,STA)) Q:'STA!(STA>999)  D
  1.  . S I=0 F  S I=$O(^PRC(411,STA,6,I)) Q:'I  D SETP(15)
  1.  ;
  1. PCARD ;
  1.  ;   Purchase Card
  1.  S J=0 F  S J=$O(^PRC(440.5,J)) Q:'J  S K=$G(^(J,0)) D 
  1.  . S STA=$P($G(^PRC(440.5,J,2)),"^",3) Q:'STA
  1.  . I $P(^PRC(440.5,J,2),"^",2)="Y" Q    ; if Inactive flag set to 'Y'
  1.  . S I=$P(K,"^",8) I I D SETP(16)       ; Purchase card holder
  1.  . S I=$P(K,"^",9) I I D SETP(18)       ; P card approving officer
  1.  . S I=$P(K,"^",10) I I D SETP(19)      ; Alt. P card approving officer
  1.  . ;   Get surrogate user which is not the card holder
  1.  . S I=0 F  S I=$O(^PRC(440.5,J,1,I)) Q:'I  D:$P(K,"^",8)'=I SETP(17)
  1.  ;
  1.  D RPT
  1. EXIT ;
  1.  K ^TMP("PRC5129")
  1.  Q
  1.  ;
  1. RPT ;
  1.  ;   Generate report from ^TMP("PRC5129")
  1.  ;     1. count from ^TMP
  1.  F IE="I","E" D
  1.  . S STA=0 F  S STA=$O(^TMP("PRC5129",$J,IE,STA)) Q:'STA  D
  1.  .. K FDT S (FDT,I)=0
  1.  .. F  S I=$O(^TMP("PRC5129",$J,IE,STA,I)) Q:'I  S J=$G(^(I)) D
  1.  ... F K=1:1:$S(IE="I":19,1:6) I $P(J,"^",K) S FDT(K)=$G(FDT(K))+1
  1.  ... S:IE="I" FDT=FDT+1
  1.  .. F K=1:1:$S(IE="I":19,1:6) D
  1.  ... S $P(^TMP("PRC5129",$J,IE,STA),"^",K)=$G(FDT(K))
  1.  .. I IE="I" S $P(^TMP("PRC5129",$J,"I",STA),"^",20)=FDT
  1.  ;     2. format report using local array
  1.  K FDT S LC=1,FDT(LC)="$REPORT"
  1.  F IE="I","E" D
  1.  . S STA=0 F  S STA=$O(^TMP("PRC5129",$J,IE,STA)) Q:'STA  S I=$G(^(STA)) D
  1.  .. I LC>1 F J=1:1:3 S LC=LC+1,FDT(LC)=""
  1.  .. S LC=LC+1,FDT(LC)="   "_$S(IE="I":"IFCAP",1:"ENGINEERING")_" USERS BY ROLE"
  1.  .. S LC=LC+1,FDT(LC)="   STATION #: "_STA
  1.  .. S LC=LC+1,FDT(LC)="       Role"_$J("Count",38)
  1.  .. F K=1:1:$S(IE="I":19,1:4) D 
  1.  ... S:IE="I" J=$P($T(FORMAT+K),";;",2)
  1.  ... S:IE="E" J=$P($T(ENGFMT+K),";;",2)
  1.  ... S LC=LC+1,FDT(LC)="       "_J_$J(+$P(I,"^",K),42-$L(J))
  1.  .. S LC=LC+1,J="Total Unique "_$S(IE="I":"IFCAP",1:"ENGINEERING")_" Users"
  1.  .. S FDT(LC)="   "_J_$J(+$P(I,"^",$S(IE="I":20,1:5)),46-$L(J))
  1.  .. I IE="E" D
  1.  ... S LC=LC+1,J="Electronic Work Order Requesters"
  1.  ... S FDT(LC)="   "_J_$J(+$P(I,"^",6),46-$L(J))
  1.  ;
  1.  ;   $DATA
  1.  ;    IFCAP data
  1.  S LC=LC+1,FDT(LC)="$DATA(IFCAP)"
  1.  S STA=0 F  S STA=$O(^TMP("PRC5129",$J,"I",STA)) Q:'STA  S J=^(STA) D
  1.  . S K="" F I=1:1:19 S K=K_+$P(J,"^",I)_","
  1.  . S LC=LC+1,FDT(LC)="Station"_STA_","_K_+$P(J,"^",20)
  1.  ;    Engineering data
  1.  S LC=LC+1,FDT(LC)="$DATA(ENGINEERING)"
  1.  S STA=$O(^TMP("PRC5129",$J,"E",0)) I STA  S J=^(STA) D
  1.  . S K="" F I=1:1:5 S K=K_+$P(J,"^",I)_","
  1.  . S LC=LC+1,FDT(LC)="Station"_STA_","_K_+$P(J,"^",6)
  1.  S LC=LC+1,FDT(LC)="$END"
  1.  ;
  1. MAIL ;
  1.  ;   get mail group member
  1.  F I=1:1 S J=$T(MAILGRP+I),J=$P(J,";;",2) Q:J=""  S XMY(J)=""
  1.  ;   mail to user who install patch 29
  1.  I $G(DUZ),$D(^VA(200,DUZ)) S XMY(DUZ)=""
  1.  S STA=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",.01)
  1.  I STA="" S STA="UNKNOWN"
  1.  S XMSUB="Extract IFCAP Users by Role ("_STA_")"
  1.  S XMTEXT="FDT("
  1.  D ^XMD
  1.  Q
  1. MAILGRP ;
  1.  ;;G.coreFLS VistA Stats@DOMAIN.EXT
  1.  ;;
  1.  Q
  1. FORMAT ;
  1.  ;;FCP Official
  1.  ;;FCP Clerk
  1.  ;;FCP Requestor
  1.  ;;Warehouse Inv Manager
  1.  ;;Primary Inv Manager
  1.  ;;Secondary Inv Manager
  1.  ;;Warehouse Inv User
  1.  ;;Primary Inv User
  1.  ;;Secondary Inv User
  1.  ;;PPM Accountable Officer
  1.  ;;Purchasing Agent
  1.  ;;Supply Manager
  1.  ;;Warehouse Employee
  1.  ;;Budget Releasing Official
  1.  ;;Accounting Staff
  1.  ;;Purchase Card Holder
  1.  ;;Purchase Card Surrogate
  1.  ;;Purchase Card Approving Official
  1.  ;;Alt PC Approving Official
  1.  ;;
  1. ENGFMT ;
  1.  ;;Asset Update
  1.  ;;Asset View Only
  1.  ;;Engr. Work Order
  1.  ;;Update Location
  1.  ;;
  1. SETP(PC) ;
  1.  ; set value into ^TMP,    STA -- station number,    I -- DUZ
  1.  ;   If termination date is smaller than today's date
  1.  I $P($G(^VA(200,I,0)),"^",11),DT>$P(^(0),"^",11) Q
  1.  I '$P($G(^TMP("PRC5129",$J,"I",STA,I)),"^",PC) S $P(^(I),"^",PC)=1
  1.  Q
  1.  ;
  1. SETE(PC) ;
  1.  ; set value into ^TMP,    ESTA -- engineer station number,    I -- DUZ
  1.  ;   If termination date is smaller than today's date
  1.  I $P($G(^VA(200,I,0)),"^",11),DT>$P(^(0),"^",11) Q
  1.  I '$P($G(^TMP("PRC5129",$J,"E",ESTA,I)),"^",PC) S $P(^(I),"^",PC)=1
  1.  Q