VistA-ccr/p/C0CACTOR.m

C0CACTOR  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
 ;;1.0;C0C;;May 19, 2009;
 ;Copyright 2008,2009 George Lilly, University of Minnesota.
 ;Licensed under the terms of the GNU General Public License.
 ;See attached copy of the License.
 ;
 ; This program is free software; you can redistribute it and/or modify
 ; it under the terms of the GNU General Public License as published by
 ; the Free Software Foundation; either version 2 of the License, or
 ; (at your option) any later version.
 ;
 ; This program is distributed in the hope that it will be useful,
 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ; GNU General Public License for more details.
 ;
 ; You should have received a copy of the GNU General Public License along
 ; with this program; if not, write to the Free Software Foundation, Inc.,
 ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 ;
 ;  PROCESS THE ACTORS SECTION OF THE CCR
 ;
 ; ===Revision History===
 ; 0.1 Initial Writing of Skeleton--GPL
 ; 0.2 Patient Data Extraction--SMH
 ; 0.3 Information System Info Extraction--SMH
 ; 0.4 Patient data rouine refactored; adjustments here--SMH
 ;
EXTRACT(IPXML,ALST,AXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE
 ; IPXML is the Input Actor Template into which we  substitute values
 ; This is straight XML. Values to be substituted are in @@VAL@@ format.
 ; ALST is the actor list global generated by ACTLST^C0CCCR and has format:
 ; ^TMP(7542,1,"ACTORS",0)=Count
 ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN"
 ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM"
 ; AXML is the output arrary, to contain XML.
 ;
 N I,J,AMAP,AOID,ATYP,AIEN
 D CP^C0CXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML
 D REPLACE^C0CXPATH(AXML,"","//Actors") ; DELETE THE INSIDES
 I DEBUG W "PROCESSING ACTORS ",!
 F I=1:1:@ALST@(0) D  ; PROCESS ALL ACTORS IN THE LIST
 . I @ALST@(I)["@@" Q  ; NOT A VALID ACTOR
 . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID
 . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE
 . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER
 . I AIEN="" D  Q  ; IEN CAN'T BE NULL
 . . W "WARING NUL ACTOR: ",ATYP,!
 . I ATYP="" Q  ; NOT A VALID ACTOR
 . ;
 . I DEBUG W AOID_" "_ATYP_" "_AIEN,!
 . I ATYP="PATIENT" D  ; PATIENT ACTOR TYPE
 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP")
 . . D PATIENT("ATMP",AIEN,AOID,"ATMP2")
 . ;
 . I ATYP="SYSTEM" D  ; SYSTEM ACTOR TYPE
 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP")
 . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2")
 . ;
 . I ATYP="NOK" D  ; NOK ACTOR TYPE
 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP")
 . . D NOK("ATMP",AIEN,AOID,"ATMP2")
 . ;
 . I ATYP="PROVIDER" D  ; PROVIDER ACTOR TYPE
 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP")
 . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2")
 . ;
 . I ATYP="ORGANIZATION" D  ; PROVIDER ACTOR TYPE
 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP")
 . . D ORG("ATMP",AIEN,AOID,"ATMP2")
 . ;
 . W "PROCESSING:",ATYP," ",AIEN,!
 . ;I @ATMP2@(0)=0 Q  ; NOTHING RETURNED, SKIP THIS ONE
 . D INSINNER^C0CXPATH(AXML,"ATMP2") ; INSERT INTO ROOT
 . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE
 ;
 N ACTTMP
 D MISSING^C0CXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS
 I ACTTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
 . ; STRINGS MARKED AS @@X@@
 . W "ACTORS Missing list: ",!
 . F I=1:1:ACTTMP(0) W ACTTMP(I),!
 Q
 ;
PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR
 I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,!
 ;GPL SEPARATED EXTRACT FROM MAP FOR PROCESSING PATIENTS - TO MAKE
 ; CODE REUSABLE FROM ERX
 N AMAP
 S AMAP=$NA(^TMP($J,"AMAP"))
 K @AMAP
 D PEXTRACT(AMAP,AIEN,AOID) ;EXTRACT THE PATIENT ACTOR
 D MAP(INXML,AMAP,OUTXML) ;MAP TO XML
 K @AMAP ; CLEAN UP BEHIND US
 Q
 ;
PEXTRACT(AMAP,AIEN,AOID) ; EXTRACT TO RETURN ARRAY RARY PASSED BY NAME
 N ZX
 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
 S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CDPT(AIEN)
 S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CDPT(AIEN)
 S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CDPT(AIEN)
 S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^C0CDPT(AIEN)
 S @AMAP@("ACTORGENDER")=$$GENDER^C0CDPT(AIEN)
 S @AMAP@("ACTORSSN")=""
 S @AMAP@("ACTORSSNTEXT")=""
 S @AMAP@("ACTORSSNSOURCEID")=""
 S X="MSCDPTID" ; ROUTINE TO TEST FOR MRN ON OPENVISTA
 X ^%ZOSF("TEST") ; TEST TO SEE IF THE ROUTINE EXISTS
 I $T S MRN=$$^MSCDPTID(DFN) ;TEST FOR MRN ON OPENVISTA ;GPL
 I $G(MRN)'="" D  ; IF MRN IS PRESENT
 . S @AMAP@("ACTORSSN")=MRN
 . S @AMAP@("ACTORSSNTEXT")="MRN"
 . S @AMAP@("ACTORSSNSOURCEID")=AOID
 E  D  ; NO MRN, USE SSN
 . S ZX=$$SSN^C0CDPT(AIEN)
 . I ZX'="" D  ; IF THERE IS A SSN IN THE RECORD
 . . S @AMAP@("ACTORSSN")=ZX
 . . S @AMAP@("ACTORSSNTEXT")="SSN"
 . . S @AMAP@("ACTORSSNSOURCEID")=AOID
 S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^C0CDPT(AIEN)
 S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^C0CDPT(AIEN)
 S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^C0CDPT(AIEN)
 S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CDPT(AIEN)
 S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CDPT(AIEN)
 S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^C0CDPT(AIEN)
 S @AMAP@("ACTORRESTEL")=""
 S @AMAP@("ACTORRESTELTEXT")=""
 S ZX=$$RESTEL^C0CDPT(AIEN)
 I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
 . S @AMAP@("ACTORRESTEL")=ZX
 . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone"
 S @AMAP@("ACTORWORKTEL")=""
 S @AMAP@("ACTORWORKTELTEXT")=""
 S ZX=$$WORKTEL^C0CDPT(AIEN)
 I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
 . S @AMAP@("ACTORWORKTEL")=ZX
 . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone"
 S @AMAP@("ACTORCELLTEL")=""
 S @AMAP@("ACTORCELLTELTEXT")=""
 S ZX=$$CELLTEL^C0CDPT(AIEN)
 I ZX'="" D  ; IF THERE IS A CELL PHONE IN THE RECORD
 . S @AMAP@("ACTORCELLTEL")=ZX
 . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone"
 S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CDPT(AIEN)
 S @AMAP@("ACTORADDRESSSOURCEID")=AOID
 S @AMAP@("ACTORIEN")=AIEN
 S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX
 S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
 Q
 ;
MAP(INXML,AMAP,OUTXML) ;MAP ANY ACTOR TO XML
 D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
 Q
 ;
SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR
     ;
     ; N AMAP
     S AMAP=$NA(^TMP($J,"AMAP"))
     K @AMAP
     S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^C0CSYS
     S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^C0CSYS
     S @AMAP@("ACTORINFOSYSSOURCEID")=AOID
     D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     Q
     ;
NOK(INXML,AIEN,AOID,OUTXML) ; PROCESS A NEXT OF KIN TYPE ACTOR
     ;
     ; N AMAP
     S AMAP=$NA(^TMP($J,"AMAP"))
     K @AMAP
     S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     S @AMAP@("ACTORDISPLAYNAME")=""
     S @AMAP@("ACTORRELATION")=""
     S @AMAP@("ACTORRELATIONSOURCEID")=""
     S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
     D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     Q
     ;
ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR
     ;
     N AMAP,ZIEN,ZSITE
     S AMAP=$NA(^TMP($J,"AMAP"))
     K @AMAP
     S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     S ZSITE=$$SITE^VASITE ; SITE FORMAT IEN^NAME^DATE
     S ZIEN=$P(ZSITE,"^",1)
     S @AMAP@("ORGANIZATIONNAME")=$P(ZSITE,U,2)
     S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1"
     S @AMAP@("ACTORADDRESSTYPE")="Office"
     S @AMAP@("ACTORADDRESSLINE1")=$$GET1^DIQ(4,ZIEN_",",1.01)
     S @AMAP@("ACTORADDRESSLINE2")=$$GET1^DIQ(4,ZIEN_",",1.02)
     S @AMAP@("ACTORADDRESSCITY")=$$GET1^DIQ(4,ZIEN_",",1.03)
     S @AMAP@("ACTORADDRESSSTATE")=$$GET1^DIQ(4,ZIEN_",",.02)
     S @AMAP@("ACTORPOSTALCODE")=$$GET1^DIQ(4,ZIEN_",",1.04)
     S @AMAP@("ACTORTELEPHONE")=""
     S @AMAP@("ACTORTELEPHONETYPE")=""
     S ZX=$$GET1^DIQ(4.03,"1,"_ZIEN_",",.03)
     I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
     . S @AMAP@("ACTORTELEPHONE")=ZX
     . S @AMAP@("ACTORTELEPHONETYPE")="Office"
     D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     K @AMAP
     Q
     ;
PROVIDER(INXML,AIEN,AOID,OUTXML) ; PROCESS A PROVIDER TYPE ACTOR
     ;
     ; N AMAP
     S AMAP=$NA(^TMP($J,"AMAP"))
     K @AMAP
     I '$D(^VA(200,AIEN,0)) D  Q  ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN)
     . W "WARNING - MISSING PROVIDER: ",AIEN,!
     . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT
     S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CVA200(AIEN)
     S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CVA200(AIEN)
     S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CVA200(AIEN)
     S @AMAP@("ACTORTITLE")=$$TITLE^C0CVA200(AIEN)
     S @AMAP@("IDTYPE")=$P($$NPI^C0CVA200(AIEN),U,1)
     S @AMAP@("ID")=$P($$NPI^C0CVA200(AIEN),U,2)
     S @AMAP@("IDDESC")=$P($$NPI^C0CVA200(AIEN),U,3)
     S @AMAP@("ACTORSPECIALITY")=$$SPEC^C0CVA200(AIEN)
     S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^C0CVA200(AIEN)
     S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^C0CVA200(AIEN)
     S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CVA200(AIEN)
     S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CVA200(AIEN)
     S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^C0CVA200(AIEN)
     S @AMAP@("ACTORTELEPHONE")=""
     S @AMAP@("ACTORTELEPHONETYPE")=""
     S ZX=$$TEL^C0CVA200(AIEN)
     I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
     . S @AMAP@("ACTORTELEPHONE")=ZX
     . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^C0CVA200(AIEN)
     S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CVA200(AIEN)
     S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1"
     S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
     S @AMAP@("ACTORORGLINK")="ACTORORGANIZATION_1"
     D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     Q
     ;