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

VBECRPCM.m

Go to the documentation of this file. 
  1. VBECRPCM ;HOIFO/BNT - MAINTENANCE USE CASE RPCs ; JULY 19, 2017@14:43
  1.  ;;2.0;VBEC;**1**;Jun 05, 2015;Build 13
  1.  ;
  1.  ; Note: This routine supports data exchange with an FDA registered
  1.  ; medical device. As such, it may not be changed in any way without
  1.  ; prior written approval from the medical device manufacturer.
  1.  ; 
  1.  ; Integration Agreements:
  1.  ; Reference DBIA 2343  - $$ACTIVE^XUSER
  1.  ; Reference DBIA 10060 - NEW PERSON FILE
  1.  ; Reference DBIA 4090  - $$CHARCHK^XOBVLIB
  1.  ; Reference DBIA 10076 - XUSEC GLOBAL READ
  1.  ; Reference DBIA 10090 - INSTITUTION FILE FILEMAN READ
  1.  ; Reference DBIA 2817  - MEDICAL CENTER DIVISION FILE "AD" X-REF
  1.  ; Reference DBIA 1963  - ACCESSION FILE GLOBAL READ
  1.  ; Reference to GETS^DIQ() supported by IA #2056
  1.  ; Reference to LIST^DIC supported by DBIA #2051
  1.  ; Call to ^VA(200 is supported by IA: 10060
  1.  ; Call to GETS^DIQ is supported by IA: 2056
  1.  ; Reference to ^DIC(4 supported by IA #10090
  1.  ; Reference to ^DG(40.8 supported by IA #2817
  1.  ; Reference to ^LRO(68 supported by IA #1963
  1.  ; 
  1.  ;
  1.  QUIT
  1.  ;
  1.  ; ---------------------------------------------------------------
  1.  ;      Private Method supports IA 4608
  1.  ; ---------------------------------------------------------------
  1. BBUSER(RESULTS) ; Look up and return all BB users
  1.  ;
  1.  ;
  1.  ; Input: RESULTS = Passed by reference used to return data to VistALink
  1.  ;                  as XML.
  1.  ;
  1.  ; Screen Logic:  Only returns users from file 200 that hold either the
  1.  ;                LRBLOODBANK or LRBLSUPER Security Key and do not have a
  1.  ;                TERMINATION DATE prior to the current date.
  1.  ;
  1.  ;S VBECCNT=0
  1.  ;S RESULTS=$NA(^TMP("VBECS_USER",$J))
  1.  ;K @RESULTS
  1.  ;D BEGROOT^VBECRPC("BloodBankUsers")
  1.  ;
  1.  ;D USRSRCH
  1.  ;
  1.  ;D ENDROOT^VBECRPC("BloodBankUsers")
  1.  N VBIEN,VBXUSEC,CNT,VBXU,VBU
  1.  S RESULTS=$NA(^TMP("BBUSERS",$J)),VBECCNT=0
  1.  K @RESULTS
  1.  D BEGROOT^VBECRPC("BloodBankUsers")
  1.  D ADD^VBECRPC("<Record count='0' >")
  1.  F VBXUSEC="LRBLOODBANK","LRBLSUPER" S VBXU=0 F  S VBXU=$O(^XUSEC(VBXUSEC,VBXU)) Q:VBXU=""  D
  1.  . Q:'+$$ACTIVE^XUSER(VBXU)
  1.  . S VBU(VBXU)=""
  1.  . Q
  1.  S (CNT,VBIEN)=0
  1.  F  S VBIEN=$O(VBU(VBIEN)) Q:VBIEN=""  D
  1.  . S CNT=CNT+1
  1.  . D BEGROOT^VBECRPC("BloodBankUser")
  1.  . D ADD^VBECRPC("<UserName>"_$$CHARCHK^XOBVLIB($P(^VA(200,VBIEN,0),"^",1))_"</UserName>")
  1.  . D ADD^VBECRPC("<UserDUZ>"_$$CHARCHK^XOBVLIB(VBIEN)_"</UserDUZ>")
  1.  . D ADD^VBECRPC("<UserInitials>"_$$CHARCHK^XOBVLIB($P(^VA(200,VBIEN,0),"^",2))_"</UserInitials>")
  1.  . D BBUSRDIV(VBIEN)
  1.  . D ENDROOT^VBECRPC("BloodBankUser")
  1.  S @RESULTS@(2)="<Record count='"_CNT_"' >"
  1.  D ENDROOT^VBECRPC("Record")
  1.  D ENDROOT^VBECRPC("BloodBankUsers")
  1.  K VBECCNT
  1.  Q
  1.  ;
  1. USRSRCH ; Search for valid Blood Bank users
  1.  ;
  1.  N DD,DIVSUB,VBUSRDUZ,VBUSRNME,VBUSRINI,IENS,BBUSRDIV,DIVERR
  1.  S DD=200,DIVSUB="200.02"
  1.  S SCREEN="I $$USRSCR^VBECRPCM(+Y)"
  1.  D LIST^DIC(DD,"","@;.01;1","P","","","","",.SCREEN,"","","ERR")
  1.  ;
  1.  D ADD^VBECRPC("<Record count='"_$$CHARCHK^XOBVLIB(+$P(^TMP("DILIST",$J,0),U))_"' >")
  1.  S X=0
  1.  F  S X=$O(^TMP("DILIST",$J,X)) Q:X=""  D
  1.  . D BEGROOT^VBECRPC("BloodBankUser")
  1.  . ; User Name
  1.  . S VBUSRNME=$P(^TMP("DILIST",$J,X,0),U,2)
  1.  . ; User DUZ
  1.  . S VBUSRDUZ=+$P(^TMP("DILIST",$J,X,0),U)
  1.  . ; User Initials
  1.  . S VBUSRINI=$P(^TMP("DILIST",$J,X,0),U,3)
  1.  . ;
  1.  . D ADD^VBECRPC("<UserName>"_$$CHARCHK^XOBVLIB(VBUSRNME)_"</UserName>")
  1.  . D ADD^VBECRPC("<UserDUZ>"_$$CHARCHK^XOBVLIB(VBUSRDUZ)_"</UserDUZ>")
  1.  . D ADD^VBECRPC("<UserInitials>"_$$CHARCHK^XOBVLIB(VBUSRINI)_"</UserInitials>")
  1.  . ;
  1.  . ; Get all Divisions for this user.
  1.  . D BBUSRDIV(VBUSRDUZ)
  1.  . ;
  1.  . D ENDROOT^VBECRPC("BloodBankUser")
  1.  . Q
  1.  D ENDROOT^VBECRPC("Record")
  1.  Q
  1.  ;
  1. BBUSRDIV(VBDUZ) ; Gets the divisions for the user and creates the XML
  1.  ;
  1.  N X,DIV,DIVIEN,OUT
  1.  ; Must be active user
  1.  S X=$$DIV4^XUSER(.DIV,VBDUZ)
  1.  Q:'X
  1.  D BEGROOT^VBECRPC("Divisions")
  1.  S DIV=0
  1.  F  S DIV=$O(DIV(DIV)) Q:DIV=""  D
  1.  . D GETDIV(.OUT,DIV)
  1.  . I '+$P(OUT,U) S ERR=$P(OUT,U,2) D ERROR(ERR) Q
  1.  . Q:'$D(OUT)
  1.  . S DIVIEN=DIV_","
  1.  . ; Check if division is active
  1.  . I $G(OUT(4,DIVIEN,101))=1 Q
  1.  . ;
  1.  . ;D BEGROOT^VBECRPC("Division")
  1.  . ;D ADD^VBECRPC("<DivisionName>"_$$CHARCHK^XOBVLIB(OUT(4,DIVIEN,.01))_"</DivisionName>")
  1.  . D ADD^VBECRPC("<Division divisionCode="""_$$CHARCHK^XOBVLIB(OUT(4,DIVIEN,99))_""" />")
  1.  . ;D ENDROOT^VBECRPC("Division")
  1.  . Q
  1.  D ENDROOT^VBECRPC("Divisions")
  1.  Q
  1.  ;
  1. USRSCR(IEN) ; Screens for valid Blood Bank Users
  1.  Q:(IEN']"")!(IEN<0) 0
  1.  Q:('$D(^XUSEC("LRBLOODBANK",IEN)))&('$D(^XUSEC("LRBLSUPER",IEN))) 0
  1.  Q +$$ACTIVE^XUSER(IEN)
  1.  ;
  1.  ; ---------------------------------------------------------------
  1.  ;      Private Method supports IA 4609
  1.  ; ---------------------------------------------------------------
  1. DIV(RESULTS) ; Lookup and return all Divisions associated with a medical center
  1.  ;
  1.  N DD,OUT,ERR,DIV,DIVIEN
  1.  S VBECCNT=0
  1.  S RESULTS=$NA(^TMP("VBECS_DIVISIONS",$J))
  1.  K @RESULTS
  1.  D BEGROOT^VBECRPC("Divisions")
  1.  ;
  1.  S DIV=0
  1.  F  S DIV=$O(^DG(40.8,"AD",DIV)) Q:DIV=""  D  Q:$D(ERR)
  1.  . D GETDIV(.OUT,DIV)
  1.  . I '+$P(OUT,U) S ERR=$P(OUT,U,2) D ERROR(ERR) Q
  1.  . Q:'$D(OUT)
  1.  . S DIVIEN=DIV_","
  1.  . ; See DR - 1670 / VistA MR 006
  1.  . ; Removed check if division is a medical center
  1.  . ; Added screen for station numbers greater than 5
  1.  . ;I $L(OUT(4,DIVIEN,99))>5 Q  ;RLM 050817
  1.  . I $G(OUT(4,DIVIEN,99))="" Q
  1.  . ; Check if division is active
  1.  . I $G(OUT(4,DIVIEN,101))="INACTIVE" Q
  1.  . D BEGROOT^VBECRPC("Division")
  1.  . D ADD^VBECRPC("<DivisionCode>"_$$CHARCHK^XOBVLIB(OUT(4,DIVIEN,99))_"</DivisionCode>")
  1.  . D ADD^VBECRPC("<DivisionName>"_$$CHARCHK^XOBVLIB(OUT(4,DIVIEN,.01))_"</DivisionName>")
  1.  . D ENDROOT^VBECRPC("Division")
  1.  D ENDROOT^VBECRPC("Divisions")
  1.  ;
  1.  K VBECCNT
  1.  Q
  1.  ;
  1. GETDIV(OUT,INST) ;
  1.  ; Returns data associated with a Division represented by the
  1.  ; Institution pointer
  1.  ;
  1.  ; Input:    OUT  = Passed by reference used to return array
  1.  ;           INST = Pointer to Institution file
  1.  ;
  1.  ; Returns:  Output from LIST^DIC in the OUT array containing data from
  1.  ;           fields .01, 99 and 101
  1.  ;
  1.  N ERR
  1.  S OUT="1^"
  1.  I INST']"" S OUT="0^Pointer to Institutuion file not found"
  1.  I INST'["," S INST=INST_","
  1.  D GETS^DIQ(4,INST,".01;99;101",,"OUT","ERR")
  1.  I $D(ERR) S OUT="0^"_ERR("DIERR",1,"TEXT",1)
  1.  Q
  1.  ;
  1.  ; ---------------------------------------------------------------
  1.  ;      Private Method Supports IA 4607
  1.  ; ---------------------------------------------------------------
  1. ACNAREA(RESULTS) ; Gets the Blood Bank Accession Areas from the Accession file
  1.  ; Supporst MUC_02 Configure Division
  1.  ;
  1.  N X,VBECARY
  1.  S (VBECCNT,X)=0
  1.  S RESULTS=$NA(^TMP("VBECS_ACCESSION_AREAS",$J))
  1.  K @RESULTS
  1.  D BEGROOT^VBECRPC("AccessionAreas")
  1.  F  S X=$O(^LRO(68,X)) Q:X'?1N.N  D
  1.  . Q:$P(^LRO(68,X,0),"^",2)'="BB" 
  1.  . S VBECARY(X)=$P(^LRO(68,X,0),"^")
  1.  . D BEGROOT^VBECRPC("AccessionArea")
  1.  . D ADD^VBECRPC("<AccessionAreaName>"_$$CHARCHK^XOBVLIB($P(^LRO(68,X,0),"^"))_"</AccessionAreaName>")
  1.  . D ADD^VBECRPC("<AccessionAreaId>"_$$CHARCHK^XOBVLIB(X)_"</AccessionAreaId>")
  1.  . D ENDROOT^VBECRPC("AccessionArea")
  1.  D ENDROOT^VBECRPC("AccessionAreas")
  1.  ;
  1.  K VBECCNT
  1.  Q
  1.  ;       
  1. ERROR(TEXT) ;
  1.  D ERROR^VBECRPC(TEXT)
  1.  Q