Ignore:
Timestamp:
Oct 1, 2012, 9:32:46 PM (12 years ago)
Author:
Sam Habiel
Message:

Merged Routines in OHUM branch back in main tree

Location:
ccr/trunk/p
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • ccr/trunk/p

  • ccr/trunk/p/C0CACTOR.m

    r1336 r1544  
    1 C0CACTOR  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ; This program is free software; you can redistribute it and/or modify
    8  ; it under the terms of the GNU General Public License as published by
    9  ; the Free Software Foundation; either version 2 of the License, or
    10  ; (at your option) any later version.
    11  ;
    12  ; This program is distributed in the hope that it will be useful,
    13  ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    14  ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    15  ; GNU General Public License for more details.
    16  ;
    17  ; You should have received a copy of the GNU General Public License along
    18  ; with this program; if not, write to the Free Software Foundation, Inc.,
    19  ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    20  ;
    21  ;  PROCESS THE ACTORS SECTION OF THE CCR
    22  ;
    23  ; ===Revision History===
    24  ; 0.1 Initial Writing of Skeleton--GPL
    25  ; 0.2 Patient Data Extraction--SMH
    26  ; 0.3 Information System Info Extraction--SMH
    27  ; 0.4 Patient data rouine refactored; adjustments here--SMH
    28  ;
    29 EXTRACT(IPXML,ALST,AXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE
    30  ; IPXML is the Input Actor Template into which we  substitute values
    31  ; This is straight XML. Values to be substituted are in @@VAL@@ format.
    32  ; ALST is the actor list global generated by ACTLST^C0CCCR and has format:
    33  ; ^TMP(7542,1,"ACTORS",0)=Count
    34  ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN"
    35  ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM"
    36  ; AXML is the output arrary, to contain XML.
    37  ;
    38  N I,J,AMAP,AOID,ATYP,AIEN
    39  D CP^C0CXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML
    40  D REPLACE^C0CXPATH(AXML,"","//Actors") ; DELETE THE INSIDES
    41  I DEBUG W "PROCESSING ACTORS ",!
    42  F I=1:1:@ALST@(0) D  ; PROCESS ALL ACTORS IN THE LIST
    43  . I @ALST@(I)["@@" Q  ; NOT A VALID ACTOR
    44  . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID
    45  . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE
    46  . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER
    47  . I AIEN="" D  Q  ; IEN CAN'T BE NULL
    48  . . W "WARING NUL ACTOR: ",ATYP,!
    49  . I ATYP="" Q  ; NOT A VALID ACTOR
    50  . ;
    51  . I DEBUG W AOID_" "_ATYP_" "_AIEN,!
    52  . I ATYP="PATIENT" D  ; PATIENT ACTOR TYPE
    53  . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP")
    54  . . D PATIENT("ATMP",AIEN,AOID,"ATMP2")
    55  . ;
    56  . I ATYP="SYSTEM" D  ; SYSTEM ACTOR TYPE
    57  . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP")
    58  . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2")
    59  . ;
    60  . I ATYP="NOK" D  ; NOK ACTOR TYPE
    61  . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP")
    62  . . D NOK("ATMP",AIEN,AOID,"ATMP2")
    63  . ;
    64  . I ATYP="PROVIDER" D  ; PROVIDER ACTOR TYPE
    65  . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP")
    66  . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2")
    67  . ;
    68  . I ATYP="ORGANIZATION" D  ; PROVIDER ACTOR TYPE
    69  . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP")
    70  . . D ORG("ATMP",AIEN,AOID,"ATMP2")
    71  . ;
    72  . W "PROCESSING:",ATYP," ",AIEN,!
    73  . ;I @ATMP2@(0)=0 Q  ; NOTHING RETURNED, SKIP THIS ONE
    74  . D INSINNER^C0CXPATH(AXML,"ATMP2") ; INSERT INTO ROOT
    75  . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE
    76  ;
    77  N ACTTMP
    78  D MISSING^C0CXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS
    79  I ACTTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
    80  . ; STRINGS MARKED AS @@X@@
    81  . W "ACTORS Missing list: ",!
    82  . F I=1:1:ACTTMP(0) W ACTTMP(I),!
    83  Q
    84  ;
    85 PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR
    86  I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,!
    87  ;GPL SEPARATED EXTRACT FROM MAP FOR PROCESSING PATIENTS - TO MAKE
    88  ; CODE REUSABLE FROM ERX
    89  N AMAP
    90  S AMAP=$NA(^TMP($J,"AMAP"))
    91  K @AMAP
    92  D PEXTRACT(AMAP,AIEN,AOID) ;EXTRACT THE PATIENT ACTOR
    93  I $P($$SITE^VASITE(),U,2)="OROVILLE HOSPITAL" S C0CDE=1
    94  I $G(C0CDE)'="" D DEIDENT(AMAP,AIEN) ; DEIDENTIFY THE CCR
    95  D MAP(INXML,AMAP,OUTXML) ;MAP TO XML
    96  K @AMAP ; CLEAN UP BEHIND US
    97  Q
    98  ;
    99 DEIDENT(GPL,ZDFN) ; QUICK WAY TO DEIDENTIFY THE CCR
    100  S @GPL@("ACTORADDRESSCITY")="ALTON"
    101  S @GPL@("ACTORADDRESSLINE1")="1234 Somewhere Lane"
    102  S @GPL@("ACTORADDRESSLINE2")=""
    103  S @GPL@("ACTORADDRESSSOURCEID")="ACTORPATIENT_"_ZDFN
    104  S @GPL@("ACTORADDRESSSTATE")="KANSAS"
    105  S @GPL@("ACTORADDRESSTYPE")="Home"
    106  S @GPL@("ACTORADDRESSZIPCODE")=67623
    107  S @GPL@("ACTORCELLTEL")=""
    108  S @GPL@("ACTORCELLTELTEXT")=""
    109  S @GPL@("ACTORDATEOFBIRTH")="1957-12-25"
    110  S @GPL@("ACTOREMAIL")=""
    111  S @GPL@("ACTORFAMILYNAME")="ZZ PATIENT"_ZDFN
    112  ;S @GPL@("ACTORGENDER")="MALE"
    113  S @GPL@("ACTORGIVENNAME")="TEST"_ZDFN
    114  S @GPL@("ACTORIEN")=2
    115  S @GPL@("ACTORMIDDLENAME")="TWO"
    116  S @GPL@("ACTOROBJECTID")="ACTORPATIENT_"_ZDFN
    117  S @GPL@("ACTORRESTEL")="888-555-1212"
    118  S @GPL@("ACTORRESTELTEXT")="Residential Telephone"
    119  S @GPL@("ACTORSOURCEID")="ACTORSYSTEM_1"
    120  S @GPL@("ACTORSSN")="769122557P"
    121  S @GPL@("ACTORSSNSOURCEID")="ACTORPATIENT_"_ZDFN
    122  S @GPL@("ACTORSSNTEXT")="SSN"
    123  S @GPL@("ACTORSUFFIXNAME")=""
    124  S @GPL@("ACTORWORKTEL")="888-121-1212"
    125  S @GPL@("ACTORWORKTELTEXT")="Work Telephone"
    126  Q
    127  ;
    128 PEXTRACT(AMAP,AIEN,AOID) ; EXTRACT TO RETURN ARRAY RARY PASSED BY NAME
    129  N ZX
    130  S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
    131  S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CDPT(AIEN)
    132  S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CDPT(AIEN)
    133  S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CDPT(AIEN)
    134  S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^C0CDPT(AIEN)
    135  S @AMAP@("ACTORGENDER")=$P($$GENDER^C0CDPT(AIEN),U,2)
    136  S @AMAP@("ACTORGENDERCODE")=$P($$GENDER^C0CDPT(AIEN),U,1)
    137  S @AMAP@("ACTORSSN")=""
    138  S @AMAP@("ACTORSSNTEXT")=""
    139  S @AMAP@("ACTORSSNSOURCEID")=""
    140  S X="MSCDPTID" ; ROUTINE TO TEST FOR MRN ON OPENVISTA
    141  X ^%ZOSF("TEST") ; TEST TO SEE IF THE ROUTINE EXISTS
    142  I $T S MRN=$$^MSCDPTID(DFN) ;TEST FOR MRN ON OPENVISTA ;GPL
    143  I $G(MRN)'="" D  ; IF MRN IS PRESENT
    144  . S @AMAP@("ACTORSSN")=MRN
    145  . S @AMAP@("ACTORSSNTEXT")="MRN"
    146  . S @AMAP@("ACTORSSNSOURCEID")=AOID
    147  E  D  ; NO MRN, USE SSN
    148  . S ZX=$$SSN^C0CDPT(AIEN)
    149  . I ZX'="" D  ; IF THERE IS A SSN IN THE RECORD
    150  . . S @AMAP@("ACTORSSN")=ZX
    151  . . S @AMAP@("ACTORSSNTEXT")="SSN"
    152  . . S @AMAP@("ACTORSSNSOURCEID")=AOID
    153  S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^C0CDPT(AIEN)
    154  S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^C0CDPT(AIEN)
    155  S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^C0CDPT(AIEN)
    156  S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CDPT(AIEN)
    157  S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CDPT(AIEN)
    158  S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^C0CDPT(AIEN)
    159  S @AMAP@("ACTORRESTEL")=""
    160  S @AMAP@("ACTORRESTELTEXT")=""
    161  S ZX=$$RESTEL^C0CDPT(AIEN)
    162  I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
    163  . S @AMAP@("ACTORRESTEL")=ZX
    164  . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone"
    165  S @AMAP@("ACTORWORKTEL")=""
    166  S @AMAP@("ACTORWORKTELTEXT")=""
    167  S ZX=$$WORKTEL^C0CDPT(AIEN)
    168  I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
    169  . S @AMAP@("ACTORWORKTEL")=ZX
    170  . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone"
    171  S @AMAP@("ACTORCELLTEL")=""
    172  S @AMAP@("ACTORCELLTELTEXT")=""
    173  S ZX=$$CELLTEL^C0CDPT(AIEN)
    174  I ZX'="" D  ; IF THERE IS A CELL PHONE IN THE RECORD
    175  . S @AMAP@("ACTORCELLTEL")=ZX
    176  . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone"
    177  S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CDPT(AIEN)
    178  S @AMAP@("ACTORADDRESSSOURCEID")=AOID
    179  S @AMAP@("ACTORIEN")=AIEN
    180  S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX
    181  S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
    182  Q
    183  ;
    184 MAP(INXML,AMAP,OUTXML) ;MAP ANY ACTOR TO XML
    185  D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
    186  Q
    187  ;
    188 SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR
    189      ;
    190      ; N AMAP
    191      S AMAP=$NA(^TMP($J,"AMAP"))
    192      K @AMAP
    193      S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
    194      S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^C0CSYS
    195      S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^C0CSYS
    196      S @AMAP@("ACTORINFOSYSSOURCEID")=AOID
    197      D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
    198      Q
    199      ;
    200 NOK(INXML,AIEN,AOID,OUTXML) ; PROCESS A NEXT OF KIN TYPE ACTOR
    201      ;
    202      ; N AMAP
    203      S AMAP=$NA(^TMP($J,"AMAP"))
    204      K @AMAP
    205      S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
    206      S @AMAP@("ACTORDISPLAYNAME")=""
    207      S @AMAP@("ACTORRELATION")=""
    208      S @AMAP@("ACTORRELATIONSOURCEID")=""
    209      S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
    210      D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
    211      Q
    212      ;
    213 ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR
    214      ;
    215      N AMAP,ZIEN,ZSITE
    216      S AMAP=$NA(^TMP($J,"AMAP"))
    217      K @AMAP
    218      S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
    219      S ZSITE=$$SITE^VASITE ; SITE FORMAT IEN^NAME^DATE
    220      S ZIEN=$P(ZSITE,"^",1)
    221      S @AMAP@("ORGANIZATIONNAME")=$P(ZSITE,U,2)
    222      S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1"
    223      S @AMAP@("ACTORADDRESSTYPE")="Office"
    224      S @AMAP@("ACTORADDRESSLINE1")=$$GET1^DIQ(4,ZIEN_",",1.01)
    225      S @AMAP@("ACTORADDRESSLINE2")=$$GET1^DIQ(4,ZIEN_",",1.02)
    226      S @AMAP@("ACTORADDRESSCITY")=$$GET1^DIQ(4,ZIEN_",",1.03)
    227      S @AMAP@("ACTORADDRESSSTATE")=$$GET1^DIQ(4,ZIEN_",",.02)
    228      S @AMAP@("ACTORPOSTALCODE")=$$GET1^DIQ(4,ZIEN_",",1.04)
    229      S @AMAP@("ACTORTELEPHONE")=""
    230      S @AMAP@("ACTORTELEPHONETYPE")=""
    231      S ZX=$$GET1^DIQ(4.03,"1,"_ZIEN_",",.03)
    232      I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
    233      . S @AMAP@("ACTORTELEPHONE")=ZX
    234      . S @AMAP@("ACTORTELEPHONETYPE")="Office"
    235      D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
    236      K @AMAP
    237      Q
    238      ;
    239 PROVIDER(INXML,AIEN,AOID,OUTXML) ; PROCESS A PROVIDER TYPE ACTOR
    240      ;
    241      ; N AMAP
    242      S AMAP=$NA(^TMP($J,"AMAP"))
    243      K @AMAP
    244      I '$D(^VA(200,AIEN,0)) D  Q  ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN)
    245      . W "WARNING - MISSING PROVIDER: ",AIEN,!
    246      . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT
    247      S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
    248      S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CVA200(AIEN)
    249      S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CVA200(AIEN)
    250      S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CVA200(AIEN)
    251      S @AMAP@("ACTORTITLE")=$$TITLE^C0CVA200(AIEN)
    252      S @AMAP@("IDTYPE")=$P($$NPI^C0CVA200(AIEN),U,1)
    253      S @AMAP@("ID")=$P($$NPI^C0CVA200(AIEN),U,2)
    254      S @AMAP@("IDDESC")=$P($$NPI^C0CVA200(AIEN),U,3)
    255      S @AMAP@("ACTORSPECIALITY")=$$SPEC^C0CVA200(AIEN)
    256      S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^C0CVA200(AIEN)
    257      S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^C0CVA200(AIEN)
    258      S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CVA200(AIEN)
    259      S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CVA200(AIEN)
    260      S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^C0CVA200(AIEN)
    261      S @AMAP@("ACTORTELEPHONE")=""
    262      S @AMAP@("ACTORTELEPHONETYPE")=""
    263      S ZX=$$TEL^C0CVA200(AIEN)
    264      I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
    265      . S @AMAP@("ACTORTELEPHONE")=ZX
    266      . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^C0CVA200(AIEN)
    267      S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CVA200(AIEN)
    268      S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1"
    269      S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
    270      S @AMAP@("ACTORORGLINK")="ACTORORGANIZATION_1"
    271      D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
    272      Q
    273      ;
     1C0CACTOR        ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
     2        ;;1.2;C0C;;May 11, 2012;Build 47
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ; This program is free software; you can redistribute it and/or modify
     8        ; it under the terms of the GNU General Public License as published by
     9        ; the Free Software Foundation; either version 2 of the License, or
     10        ; (at your option) any later version.
     11        ;
     12        ; This program is distributed in the hope that it will be useful,
     13        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     14        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     15        ; GNU General Public License for more details.
     16        ;
     17        ; You should have received a copy of the GNU General Public License along
     18        ; with this program; if not, write to the Free Software Foundation, Inc.,
     19        ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     20        ;
     21        ;  PROCESS THE ACTORS SECTION OF THE CCR
     22        ;
     23        ; ===Revision History===
     24        ; 0.1 Initial Writing of Skeleton--GPL
     25        ; 0.2 Patient Data Extraction--SMH
     26        ; 0.3 Information System Info Extraction--SMH
     27        ; 0.4 Patient data rouine refactored; adjustments here--SMH
     28        ;
     29EXTRACT(IPXML,ALST,AXML)        ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE
     30        ; IPXML is the Input Actor Template into which we  substitute values
     31        ; This is straight XML. Values to be substituted are in @@VAL@@ format.
     32        ; ALST is the actor list global generated by ACTLST^C0CCCR and has format:
     33        ; ^TMP(7542,1,"ACTORS",0)=Count
     34        ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN"
     35        ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM"
     36        ; AXML is the output arrary, to contain XML.
     37        ;
     38        N I,J,AMAP,AOID,ATYP,AIEN
     39        D CP^C0CXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML
     40        D REPLACE^C0CXPATH(AXML,"","//Actors") ; DELETE THE INSIDES
     41        I DEBUG W "PROCESSING ACTORS ",!
     42        F I=1:1:@ALST@(0) D  ; PROCESS ALL ACTORS IN THE LIST
     43        . I @ALST@(I)["@@" Q  ; NOT A VALID ACTOR
     44        . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID
     45        . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE
     46        . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER
     47        . I AIEN="" D  Q  ; IEN CAN'T BE NULL
     48        . . W "WARING NUL ACTOR: ",ATYP,!
     49        . I ATYP="" Q  ; NOT A VALID ACTOR
     50        . ;
     51        . I DEBUG W AOID_" "_ATYP_" "_AIEN,!
     52        . I ATYP="PATIENT" D  ; PATIENT ACTOR TYPE
     53        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP")
     54        . . D PATIENT("ATMP",AIEN,AOID,"ATMP2")
     55        . ;
     56        . I ATYP="SYSTEM" D  ; SYSTEM ACTOR TYPE
     57        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP")
     58        . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2")
     59        . ;
     60        . I ATYP="NOK" D  ; NOK ACTOR TYPE
     61        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP")
     62        . . D NOK("ATMP",AIEN,AOID,"ATMP2")
     63        . ;
     64        . I ATYP="PROVIDER" D  ; PROVIDER ACTOR TYPE
     65        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP")
     66        . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2")
     67        . ;
     68        . I ATYP="ORGANIZATION" D  ; PROVIDER ACTOR TYPE
     69        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP")
     70        . . D ORG("ATMP",AIEN,AOID,"ATMP2")
     71        . ;
     72        . W "PROCESSING:",ATYP," ",AIEN,!
     73        . ;I @ATMP2@(0)=0 Q  ; NOTHING RETURNED, SKIP THIS ONE
     74        . D INSINNER^C0CXPATH(AXML,"ATMP2") ; INSERT INTO ROOT
     75        . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE
     76        ;
     77        N ACTTMP
     78        D MISSING^C0CXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS
     79        I ACTTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
     80        . ; STRINGS MARKED AS @@X@@
     81        . W "ACTORS Missing list: ",!
     82        . F I=1:1:ACTTMP(0) W ACTTMP(I),!
     83        Q
     84        ;
     85PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR
     86        I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,!
     87        ;GPL SEPARATED EXTRACT FROM MAP FOR PROCESSING PATIENTS - TO MAKE
     88        ; CODE REUSABLE FROM ERX
     89        N AMAP
     90        S AMAP=$NA(^TMP($J,"AMAP"))
     91        K @AMAP
     92        D PEXTRACT(AMAP,AIEN,AOID) ;EXTRACT THE PATIENT ACTOR
     93        I $P($$SITE^VASITE(),U,2)="OROVILLE HOSPITAL" S C0CDE=1
     94        I $G(C0CDE)'="" D DEIDENT(AMAP,AIEN) ; DEIDENTIFY THE CCR
     95        D MAP(INXML,AMAP,OUTXML) ;MAP TO XML
     96        K @AMAP ; CLEAN UP BEHIND US
     97        Q
     98        ;
     99DEIDENT(GPL,ZDFN)       ; QUICK WAY TO DEIDENTIFY THE CCR
     100        S @GPL@("ACTORADDRESSCITY")="ALTON"
     101        S @GPL@("ACTORADDRESSLINE1")="1234 Somewhere Lane"
     102        S @GPL@("ACTORADDRESSLINE2")=""
     103        S @GPL@("ACTORADDRESSSOURCEID")="ACTORPATIENT_"_ZDFN
     104        S @GPL@("ACTORADDRESSSTATE")="KANSAS"
     105        S @GPL@("ACTORADDRESSTYPE")="Home"
     106        S @GPL@("ACTORADDRESSZIPCODE")=67623
     107        S @GPL@("ACTORCELLTEL")=""
     108        S @GPL@("ACTORCELLTELTEXT")=""
     109        S @GPL@("ACTORDATEOFBIRTH")="1957-12-25"
     110        S @GPL@("ACTOREMAIL")=""
     111        S @GPL@("ACTORFAMILYNAME")="ZZ PATIENT"_ZDFN
     112        ;S @GPL@("ACTORGENDER")="MALE"
     113        S @GPL@("ACTORGIVENNAME")="TEST"_ZDFN
     114        S @GPL@("ACTORIEN")=2
     115        S @GPL@("ACTORMIDDLENAME")="TWO"
     116        S @GPL@("ACTOROBJECTID")="ACTORPATIENT_"_ZDFN
     117        S @GPL@("ACTORRESTEL")="888-555-1212"
     118        S @GPL@("ACTORRESTELTEXT")="Residential Telephone"
     119        S @GPL@("ACTORSOURCEID")="ACTORSYSTEM_1"
     120        S @GPL@("ACTORSSN")="769122557P"
     121        S @GPL@("ACTORSSNSOURCEID")="ACTORPATIENT_"_ZDFN
     122        S @GPL@("ACTORSSNTEXT")="SSN"
     123        S @GPL@("ACTORSUFFIXNAME")=""
     124        S @GPL@("ACTORWORKTEL")="888-121-1212"
     125        S @GPL@("ACTORWORKTELTEXT")="Work Telephone"
     126        Q
     127        ;
     128PEXTRACT(AMAP,AIEN,AOID)        ; EXTRACT TO RETURN ARRAY RARY PASSED BY NAME
     129        N ZX
     130        S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     131        S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CDPT(AIEN)
     132        S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CDPT(AIEN)
     133        S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CDPT(AIEN)
     134        S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^C0CDPT(AIEN)
     135        S @AMAP@("ACTORGENDER")=$P($$GENDER^C0CDPT(AIEN),U,2)
     136        S @AMAP@("ACTORGENDERCODE")=$P($$GENDER^C0CDPT(AIEN),U,1)
     137        S @AMAP@("ACTORSSN")=""
     138        S @AMAP@("ACTORSSNTEXT")=""
     139        S @AMAP@("ACTORSSNSOURCEID")=""
     140        S X="MSCDPTID" ; ROUTINE TO TEST FOR MRN ON OPENVISTA
     141        X ^%ZOSF("TEST") ; TEST TO SEE IF THE ROUTINE EXISTS
     142        I $T S MRN=$$^MSCDPTID(DFN) ;TEST FOR MRN ON OPENVISTA ;GPL
     143        I $G(MRN)'="" D  ; IF MRN IS PRESENT
     144        . S @AMAP@("ACTORSSN")=MRN
     145        . S @AMAP@("ACTORSSNTEXT")="MRN"
     146        . S @AMAP@("ACTORSSNSOURCEID")=AOID
     147        E  D  ; NO MRN, USE SSN
     148        . S ZX=$$SSN^C0CDPT(AIEN)
     149        . I ZX'="" D  ; IF THERE IS A SSN IN THE RECORD
     150        . . S @AMAP@("ACTORSSN")=ZX
     151        . . S @AMAP@("ACTORSSNTEXT")="SSN"
     152        . . S @AMAP@("ACTORSSNSOURCEID")=AOID
     153        S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^C0CDPT(AIEN)
     154        S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^C0CDPT(AIEN)
     155        S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^C0CDPT(AIEN)
     156        S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CDPT(AIEN)
     157        S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CDPT(AIEN)
     158        S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^C0CDPT(AIEN)
     159        S @AMAP@("ACTORRESTEL")=""
     160        S @AMAP@("ACTORRESTELTEXT")=""
     161        S ZX=$$RESTEL^C0CDPT(AIEN)
     162        I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
     163        . S @AMAP@("ACTORRESTEL")=ZX
     164        . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone"
     165        S @AMAP@("ACTORWORKTEL")=""
     166        S @AMAP@("ACTORWORKTELTEXT")=""
     167        S ZX=$$WORKTEL^C0CDPT(AIEN)
     168        I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
     169        . S @AMAP@("ACTORWORKTEL")=ZX
     170        . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone"
     171        S @AMAP@("ACTORCELLTEL")=""
     172        S @AMAP@("ACTORCELLTELTEXT")=""
     173        S ZX=$$CELLTEL^C0CDPT(AIEN)
     174        I ZX'="" D  ; IF THERE IS A CELL PHONE IN THE RECORD
     175        . S @AMAP@("ACTORCELLTEL")=ZX
     176        . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone"
     177        S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CDPT(AIEN)
     178        S @AMAP@("ACTORADDRESSSOURCEID")=AOID
     179        S @AMAP@("ACTORIEN")=AIEN
     180        S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX
     181        S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
     182        Q
     183        ;
     184MAP(INXML,AMAP,OUTXML)  ;MAP ANY ACTOR TO XML
     185        D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     186        Q
     187        ;
     188SYSTEM(INXML,AIEN,AOID,OUTXML)  ; PROCESS A SYSTEM ACTOR
     189            ;
     190            ; N AMAP
     191            S AMAP=$NA(^TMP($J,"AMAP"))
     192            K @AMAP
     193            S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     194            S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^C0CSYS
     195            S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^C0CSYS
     196            S @AMAP@("ACTORINFOSYSSOURCEID")=AOID
     197            D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     198            Q
     199            ;
     200NOK(INXML,AIEN,AOID,OUTXML)     ; PROCESS A NEXT OF KIN TYPE ACTOR
     201            ;
     202            ; N AMAP
     203            S AMAP=$NA(^TMP($J,"AMAP"))
     204            K @AMAP
     205            S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     206            S @AMAP@("ACTORDISPLAYNAME")=""
     207            S @AMAP@("ACTORRELATION")=""
     208            S @AMAP@("ACTORRELATIONSOURCEID")=""
     209            S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
     210            D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     211            Q
     212            ;
     213ORG(INXML,AIEN,AOID,OUTXML)     ; PROCESS AN ORGANIZATION TYPE ACTOR
     214            ;
     215            N AMAP,ZIEN,ZSITE
     216            S AMAP=$NA(^TMP($J,"AMAP"))
     217            K @AMAP
     218            S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     219            S ZSITE=$$SITE^VASITE ; SITE FORMAT IEN^NAME^DATE
     220            S ZIEN=$P(ZSITE,"^",1)
     221            S @AMAP@("ORGANIZATIONNAME")=$P(ZSITE,U,2)
     222            S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1"
     223            S @AMAP@("ACTORADDRESSTYPE")="Office"
     224            S @AMAP@("ACTORADDRESSLINE1")=$$GET1^DIQ(4,ZIEN_",",1.01)
     225            S @AMAP@("ACTORADDRESSLINE2")=$$GET1^DIQ(4,ZIEN_",",1.02)
     226            S @AMAP@("ACTORADDRESSCITY")=$$GET1^DIQ(4,ZIEN_",",1.03)
     227            S @AMAP@("ACTORADDRESSSTATE")=$$GET1^DIQ(4,ZIEN_",",.02)
     228            S @AMAP@("ACTORPOSTALCODE")=$$GET1^DIQ(4,ZIEN_",",1.04)
     229            S @AMAP@("ACTORTELEPHONE")=""
     230            S @AMAP@("ACTORTELEPHONETYPE")=""
     231            S ZX=$$GET1^DIQ(4.03,"1,"_ZIEN_",",.03)
     232            I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
     233            . S @AMAP@("ACTORTELEPHONE")=ZX
     234            . S @AMAP@("ACTORTELEPHONETYPE")="Office"
     235            D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     236            K @AMAP
     237            Q
     238            ;
     239PROVIDER(INXML,AIEN,AOID,OUTXML)        ; PROCESS A PROVIDER TYPE ACTOR
     240            ;
     241            ; N AMAP
     242            S AMAP=$NA(^TMP($J,"AMAP"))
     243            K @AMAP
     244            I '$D(^VA(200,AIEN,0)) D  Q  ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN)
     245            . W "WARNING - MISSING PROVIDER: ",AIEN,!
     246            . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT
     247            S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     248            S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CVA200(AIEN)
     249            S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CVA200(AIEN)
     250            S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CVA200(AIEN)
     251            S @AMAP@("ACTORTITLE")=$$TITLE^C0CVA200(AIEN)
     252            S @AMAP@("IDTYPE")=$P($$NPI^C0CVA200(AIEN),U,1)
     253            S @AMAP@("ID")=$P($$NPI^C0CVA200(AIEN),U,2)
     254            S @AMAP@("IDDESC")=$P($$NPI^C0CVA200(AIEN),U,3)
     255            S @AMAP@("ACTORSPECIALITY")=$$SPEC^C0CVA200(AIEN)
     256            S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^C0CVA200(AIEN)
     257            S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^C0CVA200(AIEN)
     258            S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CVA200(AIEN)
     259            S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CVA200(AIEN)
     260            S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^C0CVA200(AIEN)
     261            S @AMAP@("ACTORTELEPHONE")=""
     262            S @AMAP@("ACTORTELEPHONETYPE")=""
     263            S ZX=$$TEL^C0CVA200(AIEN)
     264            I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
     265            . S @AMAP@("ACTORTELEPHONE")=ZX
     266            . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^C0CVA200(AIEN)
     267            S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CVA200(AIEN)
     268            S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1"
     269            S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
     270            S @AMAP@("ACTORORGLINK")="ACTORORGANIZATION_1"
     271            D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     272            Q
     273            ;
Note: See TracChangeset for help on using the changeset viewer.