Changes in / [30:20]


Ignore:
Location:
/ccr/trunk/p
Files:
1 deleted
6 edited

Legend:

Unmodified
Added
Removed

  • /ccr/trunk/p/CCRDPT.m

    r30 r20  
    44        ;       NOTE TO PROGRAMMER: You need to call INIT(DPT) to initialize; and
    55        ;       DESTROY to clean-up.
    6 
    7         ;       The first line of every routine tests if the global exists.
    8        
    9         ;       CCRDPT     83 lines  CCRCCD/SMH - Routines to Extract Patient Data for
    10         ;       INIT        9 lines  Copy DFN global to a local variable
    11         ;       DESTROY     6 lines  Kill local variable
    12         ;       FAMILY      6 lines  Family Name
    13         ;       GIVEN       6 lines  Given Name
    14         ;       MIDDLE      6 lines  Middle Name
    15         ;       SUFFIX      6 lines  Suffix Name       
    16         ;       DISPNAME    5 lines  Display Name
    17         ;       DOB         6 lines  Date of Birth
    18         ;       GENDER      4 lines  Get Gender
    19         ;       SSN         4 lines  Get SSN for ID
    20         ;       ADDRTYPE    4 lines  Get Home Address
    21         ;       ADDR1       4 lines  Get Home Address line 1
    22         ;       ADDR2       5 lines  Get Home Address line 2
    23         ;       CITY        4 lines  Get City for Home Address
    24         ;       STATE      11 lines  Get State for Home Address
    25         ;       ZIP         4 lines  Get Zip code for Home Address
    26         ;       COUNTY      4 lines  Get County for our Address
    27         ;       COUNTRY     4 lines  Get Country for our Address
    28         ;       RESTEL      4 lines  Residential Telephone
    29         ;       WORKTEL     4 lines  Work Telephone
    30         ;       EMAIL       4 lines  Email Adddress
    31         ;       CELLTEL     4 lines  Cell Phone
    32         ;       NOK1FAM     6 lines  Next of Kin 1 (NOK1) Family Name
    33         ;       NOK1GIV     6 lines  NOK1 Given Name
    34         ;       NOK1MID     6 lines  NOK1 Middle Name
    35         ;       NOK1SUF     6 lines  NOK1 Suffi Name
    36         ;       NOK1DISP    5 lines  NOK1 Display Name
    37         ;       NOK1REL     4 lines  NOK1 Relationship to the patient
    38         ;       NOK1ADD1    4 lines  NOK1 Address 1
    39         ;       NOK1ADD2    5 lines  NOK1 Address 2
    40         ;       NOK1CITY    4 lines  NOK1 City
    41         ;       NOK1STAT    5 lines  NOK1 State
    42         ;       NOK1ZIP     4 lines  NOK1 Zip Code
    43         ;       NOK1HTEL;   4 lines  NOK1 Home Telephone
    44         ;       NOK1WTEL;   4 lines  NOK1 Work Telephone
    45         ;       NOK1SAME;   4 lines  Is NOK1's Address the same the patient?
    46         ;       NOK2FAM     6 lines  NOK2 Family Name
    47         ;       NOK2GIV     6 lines  NOK2 Given Name
    48         ;       NOK2MID     6 lines  NOK2 Middle Name
    49         ;       NOK2SUF     5 lines  NOK2 Suffi Name
    50         ;       NOK2DISP    5 lines  NOK2 Display Name
    51         ;       NOK2REL     4 lines  NOK2 Relationship to the patient
    52         ;       NOK2ADD1    4 lines  NOK2 Address 1
    53         ;       NOK2ADD2    5 lines  NOK2 Address 2
    54         ;       NOK2CITY    4 lines  NOK2 City
    55         ;       NOK2STAT    5 lines  NOK2 State
    56         ;       NOK2ZIP     4 lines  NOK2 Zip Code
    57         ;       NOK2HTEL;   4 lines  NOK2 Home Telephone
    58         ;       NOK2WTEL;   4 lines  NOK2 Work Telephone
    59         ;       NOK2SAME;   4 lines  Is NOK2's Address the same the patient?
    60         ;       EMERFAM     6 lines  Emergency Contact (EMER) Family Name
    61         ;       EMERGIV     6 lines  EMER Given Name
    62         ;       EMERMID     6 lines  EMER Middle Name
    63         ;       EMERSUF     5 lines  EMER Suffi Name
    64         ;       EMERDISP    5 lines  EMER Display Name
    65         ;       EMERREL     4 lines  EMER Relationship to the patient
    66         ;       EMERADD1    4 lines  EMER Address 1
    67         ;       EMERADD2    5 lines  EMER Address 2
    68         ;       EMERCITY    4 lines  EMER City
    69         ;       EMERSTAT    5 lines  EMER State
    70         ;       EMERZIP     4 lines  EMER Zip Code
    71         ;       EMERHTEL;   4 lines  EMER Home Telephone
    72         ;       EMERWTEL;   4 lines  EMER Work Telephone
    73         ;       EMERSAME;   4 lines  Is EMER's Address the same the NOK?
    746
    757        W "No Entry at top!" Q
    … …  
    16799FAMILY() ; Family Name; PUBLIC; Extrinsic
    168100        ; PREREQ: PT Defined
    169         Q:$G(PT(0))="" ""
    170101        N NAME S NAME=$P(PT(0),"^",1)
    171102        D NAMECOMP^XLFNAME(.NAME)
    … …  
    174105GIVEN() ; Given Name; PUBLIC; Extrinsic
    175106        ; PREREQ: PT Defined
    176         Q:$G(PT(0))="" ""
    177107        N NAME S NAME=$P(PT(0),"^",1)
    178108        D NAMECOMP^XLFNAME(.NAME)
    … …  
    181111MIDDLE() ; Middle Name; PUBLIC; Extrinsic
    182112        ; PREREQ: PT Defined
    183         Q:$G(PT(0))="" ""
    184113        N NAME S NAME=$P(PT(0),"^",1)
    185114        D NAMECOMP^XLFNAME(.NAME)
    … …  
    188117SUFFIX() ; Suffi Name; PUBLIC; Extrinsic
    189118        ; PREREQ: PT Defined
    190         Q:$G(PT(0))="" ""
    191119        N NAME S NAME=$P(PT(0),"^",1)
    192120        D NAMECOMP^XLFNAME(.NAME)
    … …  
    195123DISPNAME() ; Display Name; PUBLIC; Extrinsic
    196124        ; PREREQ: PT Defined
    197         Q:$G(PT(0))="" ""
    198125        N NAME S NAME=$P(PT(0),"^",1)
    199126        Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    … …  
    201128DOB() ; Date of Birth; PUBLIC; Extrinsic
    202129        ; PREREQ: PT Defined
    203         Q:$G(PT(0))="" ""
    204130        N DOB S DOB=$P(PT(0),"^",3)
    205131        ; Date in FM Date Format. Convert to UTC/ISO 8601.
    … …  
    208134GENDER() ; Get Gender; PUBLIC; Extrinsic
    209135        ; PREREQ: PT Defined
    210         Q:$G(PT(0))="" ""
    211136        Q $P(PT(0),"^",2)
    212137        ;
    213138SSN() ; Get SSN for ID; PUBLIC; Extrinsic
    214139        ; PREREQ: PT Defined
    215         Q:$G(PT(0))="" ""
    216140        Q $P(PT(0),"^",9)
    217141        ;
    218 ADDRTYPE() ; Get Home Address; PUBLIC; Extrinsic
     142ADDRTYPE(ADDR) ; Get Home Address; PUBLIC; Extrinsic
    219143        ; Vista only stores a home address for the patient.
    220         Q:$G(PT(0))="" ""
    221144        Q "Home"
    222145        ;
    223146ADDR1() ; Get Home Address line 1; PUBLIC; Extrinsic
    224147        ; PREREQ: PT Defined
    225         Q:$G(PT(.11))="" ""
    226148        Q $P(PT(.11),"^",1)
    227149        ;
    … …  
    229151        ; PREREQ: PT Defined
    230152        ; Vista has Lines 2,3; CCR has only line 1,2; so compromise
    231         Q:$G(PT(.11))="" ""
    232         ; If the thrid address is empty, just return the 2nd.
    233         ; If the 2nd is empty, we don't lose, b/c it will return ""
    234         ; This is so that we won't produce a comma if there is no 3rd addr.
    235         Q:$P(PT(.11),"^",3)="" $P(PT(.11),"^",2)
    236153        Q $P(PT(.11),"^",2)_", "_$P(PT(.11),"^",3)
    237154        ;
    238155CITY() ; Get City for Home Address; PUBLIC; Extrinsic
    239156        ; PREREQ: PT Defined
    240         Q:$G(PT(.11))="" ""
    241157        Q $P(PT(.11),"^",4)
    242158        ;
    243159STATE() ; Get State for Home Address; PUBLIC; Extrinsic
    244160        ; PREREQ: PT Defined
    245         Q:$G(PT(.11))="" ""
    246161        ; State is stored as a pointer
    247         N STATENUM S STATENUM=$P(PT(.11),"^",5)
     162        N STATENUM=$P(PT(.11)"^",5)
    248163        ;
    249164        ; State File Global is below
    … …  
    251166    ; ==>[3F] ^ (#5) CAPITAL [4F] ^ (#2.1) AAC RECOGNIZED [5S] ^ (#2.2)
    252167    ; ==>US STATE OR POSSESSION [6S] ^
    253         Q:STATENUM="" ""  ; To prevent global undefined below if no state
    254168        Q $P(^DIC(5,STATENUM,0),"^",1)
    255169        ;
    256 ZIP() ; Get Zip code for Home Address; PUBLIC; Extrinsic
     170ZIP() ; Get Zip code for Home Address
    257171        ; PREREQ: PT Defined
    258         Q:$G(PT(.11))="" ""
    259172        Q $P(PT(.11),"^",6)
    260173        ;
    261 COUNTY() ; Get County for our Address; PUBLIC; Extrinsic
     174COUNTY() ; Get County for our Address
    262175        ; PREREQ: PT Defined
    263         Q:$G(PT(.11))="" ""
    264176        Q $P(PT(.11),"^",7)
    265177        ;
    266 COUNTRY() ; Get Country for our Address; PUBLIC; Extrinsic
    267         ; Unfortunately, I can't find where that is stored, so the inevitable...
    268         Q:$G(PT(.11))="" ""
    269         Q "USA"
    270         ;
    271 RESTEL() ; Residential Telephone; PUBLIC; Extrinsic
    272         ; PREREQ: PT Defined
    273         Q:$G(PT(.13))="" ""
    274         Q $P(PT(.13),"^",1)
    275         ;
    276 WORKTEL() ; Work Telephone; PUBLIC; Extrinsic
    277         ; PREREQ: PT Defined
    278         Q:$G(PT(.13))="" ""
    279         Q $P(PT(.13),"^",2)
    280         ;
    281 EMAIL() ; Email Adddress; PUBLIC; Extrinsic
    282         ; PREREQ: PT Defined
    283         Q:$G(PT(.13))="" ""
    284         Q $P(PT(.13),"^",3)
    285         ;
    286 CELLTEL() ; Cell Phone; PUBLIC; Extrinsic
    287         ; PREREQ: PT Defined
    288         Q:$G(PT(.13))="" ""
    289         Q $P(PT(.13),"^",4)
    290         ;
    291 NOK1FAM() ; Next of Kin 1 (NOK1) Family Name; PUBLIC; Extrinsic
    292         ; PREREQ: PT Defined
    293         Q:$G(PT(.21))="" ""
    294         N NAME S NAME=$P(PT(.21),"^",1)
    295         D NAMECOMP^XLFNAME(.NAME)
    296         Q NAME("FAMILY")
    297         ;
    298 NOK1GIV() ; NOK1 Given Name; PUBLIC; Extrinsic
    299         ; PREREQ: PT Defined
    300         Q:$G(PT(.21))="" ""
    301         N NAME S NAME=$P(PT(.21),"^",1)
    302         D NAMECOMP^XLFNAME(.NAME)
    303         Q NAME("GIVEN")
    304         ;
    305 NOK1MID() ; NOK1 Middle Name; PUBLIC; Extrinsic
    306         ; PREREQ: PT Defined
    307         Q:$G(PT(.21))="" ""
    308         N NAME S NAME=$P(PT(.21),"^",1)
    309         D NAMECOMP^XLFNAME(.NAME)
    310         Q NAME("MIDDLE")
    311         ;
    312 NOK1SUF() ; NOK1 Suffi Name; PUBLIC; Extrinsic
    313         ; PREREQ: PT Defined
    314         Q:$G(PT(.21))="" ""
    315         N NAME S NAME=$P(PT(.21),"^",1)
    316         D NAMECOMP^XLFNAME(.NAME)
    317         Q NAME("SUFFIX")
    318         ;
    319 NOK1DISP() ; NOK1 Display Name; PUBLIC; Extrinsic
    320         ; PREREQ: PT Defined
    321         Q:$G(PT(.21))="" ""
    322         N NAME S NAME=$P(PT(.21),"^",1)
    323         Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    324         ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    325 NOK1REL() ; NOK1 Relationship to the patient; PUBLIC; Extrinsic
    326         ; PREREQ: PT Defined
    327         Q:$G(PT(.21))="" ""
    328         Q $P(PT(.21),"^",2)
    329         ;
    330 NOK1ADD1() ; NOK1 Address 1; PUBLIC; Extrinsic
    331         ; PREREQ: PT Defined
    332         Q:$G(PT(.21))="" ""
    333         Q $P(PT(.21),"^",3)
    334         ;
    335 NOK1ADD2() ; NOK1 Address 2; PUBLIC; Extrinsic
    336         ; PREREQ: PT Defined
    337         ; As before, CCR only allows two fileds for the address, so we have to compromise
    338         Q:$G(PT(.21))="" ""
    339         ; If the thrid address is empty, just return the 2nd.
    340         ; If the 2nd is empty, we don't lose, b/c it will return ""
    341         ; This is so that we won't produce a comma if there is no 3rd addr.
    342         Q:$P(PT(.21),"^",5)="" $P(PT(.21),"^",4)
    343         Q $P(PT(.21),"^",4)_", "_$P(PT(.21),"^",5)
    344         ;
    345 NOK1CITY() ; NOK1 City; PUBLIC; Extrinsic
    346         ; PREREQ: PT Defined
    347         Q:$G(PT(.21))="" ""
    348         Q $P(PT(.21),"^",6)
    349         ;
    350 NOK1STAT() ; NOK1 State; PUBLIC; Extrinsic
    351         ; PREREQ: PT Defined
    352         Q:$G(PT(.21))="" ""
    353         N STATENUM S STATENUM=$P(PT(.21),"^",7)
    354         Q:STATENUM="" ""
    355         Q $P(^DIC(5,STATENUM,0),"^",1)
    356         ;
    357 NOK1ZIP() ; NOK1 Zip Code; PUBLIC; Extrinsic
    358         ; PREREQ: PT Defined
    359         Q:$G(PT(.21))="" ""
    360         Q $P(PT(.21),"^",8)
    361         ;
    362 NOK1HTEL() ; NOK1 Home Telephone; PUBLIC; Extrinsic
    363         ; PREREQ: PT Defined
    364         Q:$G(PT(.21))="" ""
    365         Q $P(PT(.21),"^",9)
    366         ;
    367 NOK1WTEL() ; NOK1 Work Telephone; PUBLIC; Extrinsic
    368         ; PREREQ: PT Defined
    369         Q:$G(PT(.21))="" ""
    370         Q $P(PT(.21),"^",11)
    371         ;
    372 NOK1SAME() ; Is NOK1's Address the same the patient?; PUBLIC; Extrinsic
    373         ; PREREQ: PT Defined
    374         Q:$G(PT(.21))="" ""
    375         Q $P(PT(.21),"^",10)
    376         ;
    377 NOK2FAM() ; NOK2 Family Name; PUBLIC; Extrinsic
    378         ; PREREQ: PT Defined
    379         Q:$G(PT(.211))="" ""
    380         N NAME S NAME=$P(PT(.211),"^",1)
    381         D NAMECOMP^XLFNAME(.NAME)
    382         Q NAME("FAMILY")
    383         ;
    384 NOK2GIV() ; NOK2 Given Name; PUBLIC; Extrinsic ; PREREQ: PT Defined
    385         Q:$G(PT(.211))="" ""
    386         N NAME S NAME=$P(PT(.211),"^",1)
    387         D NAMECOMP^XLFNAME(.NAME)
    388         Q NAME("GIVEN")
    389         ;
    390 NOK2MID() ; NOK2 Middle Name; PUBLIC; Extrinsic
    391         ; PREREQ: PT Defined
    392         Q:$G(PT(.211))="" ""
    393         N NAME S NAME=$P(PT(.211),"^",1)
    394         D NAMECOMP^XLFNAME(.NAME)
    395         Q NAME("MIDDLE")
    396         ;
    397 NOK2SUF() ; NOK2 Suffi Name; PUBLIC; Extrinsic
    398         ; PREREQ: PT Defined
    399         Q:$G(PT(.211))="" ""
    400         N NAME S NAME=$P(PT(.211),"^",1)
    401         D NAMECOMP^XLFNAME(.NAME)
    402         Q NAME("SUFFIX")
    403 NOK2DISP() ; NOK2 Display Name; PUBLIC; Extrinsic
    404         ; PREREQ: PT Defined
    405         Q:$G(PT(.211))="" ""
    406         N NAME S NAME=$P(PT(.211),"^",1)
    407         Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    408         ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    409 NOK2REL() ; NOK2 Relationship to the patient; PUBLIC; Extrinsic
    410         ; PREREQ: PT Defined
    411         Q:$G(PT(.211))="" ""
    412         Q $P(PT(.211),"^",2)
    413         ;
    414 NOK2ADD1() ; NOK2 Address 1; PUBLIC; Extrinsic
    415         ; PREREQ: PT Defined
    416         Q:$G(PT(.211))="" ""
    417         Q $P(PT(.211),"^",3)
    418         ;
    419 NOK2ADD2() ; NOK2 Address 2; PUBLIC; Extrinsic
    420         ; PREREQ: PT Defined
    421         ; As before, CCR only allows two fileds for the address, so we have to compromise
    422         Q:$G(PT(.211))="" ""
    423         ; If the thrid address is empty, just return the 2nd.
    424         ; If the 2nd is empty, we don't lose, b/c it will return ""
    425         ; This is so that we won't produce a comma if there is no 3rd addr.
    426         Q:$P(PT(.211),"^",5)="" $P(PT(.211),"^",4)
    427         Q $P(PT(.211),"^",4)_", "_$P(PT(.211),"^",5)
    428         ;
    429 NOK2CITY() ; NOK2 City; PUBLIC; Extrinsic
    430         ; PREREQ: PT Defined
    431         Q:$G(PT(.211))="" ""
    432         Q $P(PT(.211),"^",6)
    433         ;
    434 NOK2STAT() ; NOK2 State; PUBLIC; Extrinsic
    435         ; PREREQ: PT Defined
    436         Q:$G(PT(.211))="" ""
    437         N STATENUM S STATENUM=$P(PT(.211),"^",7)
    438         Q:STATENUM="" ""  ; To prevent global undefined below if no state
    439         Q $P(^DIC(5,STATENUM,0),"^",1) ; Explained above
    440         ;
    441 NOK2ZIP() ; NOK2 Zip Code; PUBLIC; Extrinsic
    442         ; PREREQ: PT Defined
    443         Q:$G(PT(.211))="" ""
    444         Q $P(PT(.211),"^",8)
    445         ;
    446 NOK2HTEL() ; NOK2 Home Telephone; PUBLIC; Extrinsic
    447         ; PREREQ: PT Defined
    448         Q:$G(PT(.211))="" ""
    449         Q $P(PT(.211),"^",9)
    450         ;
    451 NOK2WTEL() ; NOK2 Work Telephone; PUBLIC; Extrinsic
    452         ; PREREQ: PT Defined
    453         Q:$G(PT(.211))="" ""
    454         Q $P(PT(.211),"^",11)
    455         ;
    456 NOK2SAME() ; Is NOK2's Address the same the patient?; PUBLIC; Extrinsic
    457         ; PREREQ: PT Defined
    458         Q:$G(PT(.211))="" ""
    459         Q $P(PT(.211),"^",10)
    460         ;
    461 EMERFAM() ; Emergency Contact (EMER) Family Name; PUBLIC; Extrinsic
    462         ; PREREQ: PT Defined
    463         Q:$G(PT(.33))="" ""
    464         N NAME S NAME=$P(PT(.33),"^",1)
    465         D NAMECOMP^XLFNAME(.NAME)
    466         Q NAME("FAMILY")
    467         ;
    468 EMERGIV() ; EMER Given Name; PUBLIC; Extrinsic
    469         ; PREREQ: PT Defined
    470         Q:$G(PT(.33))="" ""
    471         N NAME S NAME=$P(PT(.33),"^",1)
    472         D NAMECOMP^XLFNAME(.NAME)
    473         Q NAME("GIVEN")
    474         ;
    475 EMERMID() ; EMER Middle Name; PUBLIC; Extrinsic
    476         ; PREREQ: PT Defined
    477         Q:$G(PT(.33))="" ""
    478         N NAME S NAME=$P(PT(.33),"^",1)
    479         D NAMECOMP^XLFNAME(.NAME)
    480         Q NAME("MIDDLE")
    481         ;
    482 EMERSUF() ; EMER Suffi Name; PUBLIC; Extrinsic
    483         ; PREREQ: PT Defined
    484         Q:$G(PT(.33))="" ""
    485         N NAME S NAME=$P(PT(.33),"^",1)
    486         D NAMECOMP^XLFNAME(.NAME)
    487         Q NAME("SUFFIX")
    488 EMERDISP() ; EMER Display Name; PUBLIC; Extrinsic
    489         ; PREREQ: PT Defined
    490         Q:$G(PT(.33))="" ""
    491         N NAME S NAME=$P(PT(.33),"^",1)
    492         Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    493         ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    494 EMERREL() ; EMER Relationship to the patient; PUBLIC; Extrinsic
    495         ; PREREQ: PT Defined
    496         Q:$G(PT(.33))="" ""
    497         Q $P(PT(.33),"^",2)
    498         ;
    499 EMERADD1() ; EMER Address 1; PUBLIC; Extrinsic
    500         ; PREREQ: PT Defined
    501         Q:$G(PT(.33))="" ""
    502         Q $P(PT(.33),"^",3)
    503         ;
    504 EMERADD2() ; EMER Address 2; PUBLIC; Extrinsic
    505         ; PREREQ: PT Defined
    506         ; As before, CCR only allows two fileds for the address, so we have to compromise
    507         Q:$G(PT(.33))="" ""
    508         ; If the thrid address is empty, just return the 2nd.
    509         ; If the 2nd is empty, we don't lose, b/c it will return ""
    510         ; This is so that we won't produce a comma if there is no 3rd addr.
    511         Q:$P(PT(.33),"^",5)="" $P(PT(.33),"^",4)
    512         Q $P(PT(.33),"^",4)_", "_$P(PT(.33),"^",5)
    513         ;
    514 EMERCITY() ; EMER City; PUBLIC; Extrinsic
    515         ; PREREQ: PT Defined
    516         Q:$G(PT(.33))="" ""
    517         Q $P(PT(.33),"^",6)
    518         ;
    519 EMERSTAT() ; EMER State; PUBLIC; Extrinsic
    520         ; PREREQ: PT Defined
    521         Q:$G(PT(.33))="" ""
    522         N STATENUM S STATENUM=$P(PT(.33),"^",7)
    523         Q:STATENUM="" ""  ; To prevent global undefined below if no state
    524         Q $P(^DIC(5,STATENUM,0),"^",1) ; Explained above
    525         ;
    526 EMERZIP() ; EMER Zip Code; PUBLIC; Extrinsic
    527         ; PREREQ: PT Defined
    528         Q:$G(PT(.33))="" ""
    529         Q $P(PT(.33),"^",8)
    530         ;
    531 EMERHTEL() ; EMER Home Telephone; PUBLIC; Extrinsic
    532         ; PREREQ: PT Defined
    533         Q:$G(PT(.33))="" ""
    534         Q $P(PT(.33),"^",9)
    535         ;
    536 EMERWTEL() ; EMER Work Telephone; PUBLIC; Extrinsic
    537         ; PREREQ: PT Defined
    538         Q:$G(PT(.33))="" ""
    539         Q $P(PT(.33),"^",11)
    540         ;
    541 EMERSAME() ; Is EMER's Address the same the NOK?; PUBLIC; Extrinsic
    542         ; PREREQ: PT Defined
    543         Q:$G(PT(.33))="" ""
    544         Q $P(PT(.33),"^",10)
    545         ;

  • /ccr/trunk/p/GPLCCR.m

    r30 r20  
    77        ; Select a patient for real.
    88        S DIC=2,DIC(0)="AEMQ" D ^DIC
    9         I Y<1 Q ; EXIT
    109        S DFN=$P(Y,U,1) ; SET THE PATIENT
    1110        N CCRGLO
    … …  
    1312        S OARY=$NA(^TMP($J,DFN,"CCR",1))
    1413        S ONAM="PAT_"_DFN_"_CCR_V1.xml"
    15         S ODIR="/home/glilly/CCROUT"
     14        S ODIR="/home/wvehr1/EHR/CCR"
    1615        D OUTPUT^GPLXPATH(OARY,ONAM,ODIR)
    1716        Q
    … …  
    2120        S TGLOBAL=$NA(^TMP($J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE
    2221        S CCRGLO=$NA(^TMP($J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR
    23         S ACTGLO=$NA(^TMP($J,DFN,"ACTORS")); GLOBAL FOR ALL ACTORS IN CCR
    2422        ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC
    2523        S CCRGRTN=$NA(^TMP($J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL OF CCR
    … …  
    2826        ;
    2927        ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM THE CCR GLOBAL
    30         ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH PROCESSING ROUTINES
     28        ; THESE WILL BE POPULATED WITH CALLS TO THE XPATH PROCESSING ROUTINES
    3129        D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body")
    3230        D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors")
    3331        D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures")
    34         I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),!
     32        F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),!
    3533        ;
    36         D CCRHDR(CCRGLO,DFN) ; MAP HEADER VARIABLES
    3734        S CCRXTAB="^TMP($J,""CCRSTEP"")" ; GLOBAL TO STORE CCR PROCESSING STEPS
    3835        D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS
    … …  
    5148        . X CALL
    5249        . ; NOW INSERT THE RESULTS IN THE CCR BUFFER
    53         . D INSERT^GPLXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body")
     50        . ; D INSERT^GPLXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body")
    5451        . I DEBUG F GPLI=1:1:@OXML@(0) W @OXML@(GPLI),!
    55         . D ACTLST^GPLCCR(CCRGLO,ACTGLO)
     52        . D QOPEN^GPLXPATH("CCRBLD",CCRGLO,"//ContinuityOfCareRecord/Body")
     53        . D QUEUE^GPLXPATH("CCRBLD",OXML,1,@OXML@(0))
     54        . D QCLOSE^GPLXPATH("CCRBLD",CCRGLO,"//ContinuityOfCareRecord/Body")
     55        . I DEBUG W "GOING TO BUILD CCR",!
     56        . N CCRTMP
     57        . D BUILD^GPLXPATH("CCRBLD","CCRTMP")
     58        . I DEBUG F GPLI=1:1:CCRTMP(0) W CCRTMP(GPLI),!
     59        . D CP^GPLXPATH("CCRTMP",CCRGLO)
    5660        Q
    5761        ;
    … …  
    6367        Q
    6468         ;
    65 CCRHDR(CXML,DFN) ; MAP HEADER VARIABLES: FROM, TO ECT
    66         N VMAP S VMAP=$NA(^TMP($J,DFN,"HEADER"))
    67         ; K @VMAP
    68         S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN
    69         S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - ???
    70         S @VMAP@("ACTORFROM2")="ACTORPROVIDER_"_DUZ ; NEED A BETTER WAY
    71         S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN  ; FOR TEST PURPOSES,
    72         ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT
    73         N CTMP
    74         D MAP^GPLXPATH(CXML,VMAP,"CTMP")
    75         D CP^GPLXPATH("CTMP",CXML)
    76         Q
    77         ;
    78 ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML
    79         ; AXML AND ACTRTN ARE PASSED BY NAME
    80         N I,J,K
    81         K @ACTRTN ; CLEAR RETURN ARRAY
    82         F I=1:1:@AXML@(0) D  ; SCAN ALL LINES
    83         . I @AXML@(I)?.E1"<ActorID>".E D  ; THERE IS AN ACTOR ON THIS LINE
    84         . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1)
    85         . . W "<ActorID>=>",J,!
    86         . . S K(J)="" ; HASHING ACTOR TO GET RID OF MULTIPLES
    87         S I="" ; GOING TO $O THROUGH THE HASH
    88         F J=0:0 D  Q:$O(K(I))=""
    89         . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS
    90         . D PUSH^GPLXPATH(ACTRTN,I) ; ADD THE ACTOR TO THE RETURN ARRAY
    91         Q
    92         ;
    9369TEST   ; RUN ALL THE TEST CASES
    94       ;D TESTALL^GPLUNIT("GPLCCR")
    95       D ZTEST^GPLCCR("PROBLEMS")
    96       W "TESTING RETURNED FROM PROBLMES",!
    97       D ZTEST^GPLCCR("CCR")
     70      N ZTMP
     71      D ZLOAD^GPLUNIT("ZTMP","GPLCCR")
     72      D ZTEST^GPLUNIT(.ZTMP,"ALL")
     73      W !
     74      ; W "THE TESTS!",!
     75      ; ZWR ZTMP
    9876      Q
    9977      ;
    … …  
    11189      ;
    11290;;><TEST>
    113 ;;><PROBLEMS>
     91;;><INIT>
    11492;;>>>K GPL S GPL=""
    115 ;;>>>D CCRRPC^GPLCCR(.GPL,"2","PROBLEMS")
    116 ;;>>?@GPL@(@GPL@(0))="</Problems>"
    117 ;;><CCR>
    118 ;;>>>K GPL S GPL=""
    119 ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR")
    120 ;;>>?@GPL@(@GPL@(0))="</ContinutiyOfCareRecord>"
    121 ;;><ACTLST>
    122 ;;>>>N TCCR
    123 ;;>>>D CCRRPC^GPLCCR(.TCCR,"2","CCR")
    124 ;;>>>D ACTLST^GPLCCR("TCCR","ACTTEST")
    12593;;></TEST>

  • /ccr/trunk/p/GPLCCR0.m

    r30 r20  
    4747;<TEMPLATE>
    4848;;<?xml version="1.0" encoding="UTF-8"?>
    49 ;;<?xml-stylesheet type="text/xsl" href="ccr_20060420.xsl"?>
    5049;;<ContinuityOfCareRecord xmlns="urn:astm-org:CCR">
    5150;;<CCRDocumentObjectID>871bd605-e8f8-4b80-9918-4b03f781129e</CCRDocumentObjectID>
    … …  
    9291;;<Code>
    9392;;<Value>@@PROBLEMCODEVALUE@@</Value>
    94 ;;<CodingSystem>ICD9CM</CodingSystem>
    95 ;;<Version>@@PROBLEMCODINGVERSION@@</Version>
     93;;<CodingSystem>@@PROBLEMCODINGSYSTEM@@ICD9CM</CodingSystem>
     94;;<Version>@@PROBLEMCODINGVERSION@@2007</Version>
    9695;;</Code>
    9796;;</Description>

  • /ccr/trunk/p/GPLPROBS.m

    r30 r20  
    1515    D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC
    1616    I '$D(RPCRSLT(0)) W "ERROR CALLING LIST^ORQQPL3 ",! Q
    17     ZWR RPCRSLT
     17    I DEBUG ZWR RPCRSLT
    1818    S TVMAP=$NA(^TMP($J,"PROBVALS"))
    1919    S TARYTMP=$NA(^TMP($J,"PROBARYTMP"))

  • /ccr/trunk/p/GPLUNIT.m

    r30 r20  
    1717        S ZARY(CNT)=TST ; put the test in the array
    1818        I $D(ZARY(BAT))  D  ; NOT THE FIRST TEST IN BATTERY
    19         . N II,TN ; TEMP FOR ENDING TEST IN BATTERY
     19        . N II ; TEMP FOR ENDING TEST IN BATTERY
    2020        . S II=$P(ZARY(BAT),"^",2)
    2121        . S $P(ZARY(BAT),"^",2)=II+1
    … …  
    2323        . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY
    2424        . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX
    25         . ; S TN=$NA(ZARY("TESTS"))
    26         . ; D PUSH^GPLXPATH(TN,BAT)
    2725        S ZARY(0)=CNT ; update the array counter
    2826        Q
    … …  
    5250       ;
    5351ZTEST(ZARY,WHICH)   ; try out the tests using a passed array ZTEST
    54         N I,ZX,ZR,ZP
    55         S DEBUG=0
    56         ; I WHICH="ALL" D  Q ; RUN ALL THE TESTS
    57         ; . W "DOING ALL",!
    58         ; . N J,NT
    59         ; . S NT=$NA(ZARY("TESTS"))
    60         ; . W NT,@NT@(0),!
    61         ; . F J=1:1:@NT@(0) D  ;
    62         ; . . W @NT@(J),!
    63         ; . . D ZTEST^GPLUNIT(@ZARY,@NT@(J))
    64         I '$D(ZARY(WHICH))  D  ; TEST SECTION DOESN'T EXIST
    65         . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,!
    66         . Q ; EXIT
    67         N FIRST,LAST
    68         S FIRST=$P(ZARY(WHICH),"^",1)
    69         S LAST=$P(ZARY(WHICH),"^",2)
    70         F I=FIRST:1:LAST  D
    71         . I ZARY(I)?1">"1.E  D  ; NOT A TEST, JUST RUN THE STATEMENT
    72         . . S ZP=$E(ZARY(I),2,$L(ZARY(I)))
    73         . . ;  W ZP,!
    74         . . S ZX=ZP
    75         . . W "RUNNING: "_ZP
    76         . . X ZX
    77         . . W "..SUCCESS: ",WHICH,!
    78         . I ZARY(I)?1"?"1.E  D  ; THIS IS A TEST
    79         . . S ZP=$E(ZARY(I),2,$L(ZARY(I)))
    80         . . S ZX="S ZR="_ZP
    81         . . W "TRYING: "_ZP
    82         . . X ZX
    83         . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),!
    84         . . I '$D(TPASSED) D  ; NOT INITIALIZED YET
    85         . . . S TPASSED=0 S TFAILED=0
    86         . . I ZR S TPASSED=TPASSED+1
    87         . . I 'ZR S TFAILED=TFAILED+1
    88         Q
    89         ;
     52       N I,ZX,ZR,ZP
     53       S DEBUG=0
     54       I '$D(ZARY(WHICH))  D  ; TEST SECTION DOESN'T EXIST
     55       . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,!
     56       . Q ; EXIT
     57       N FIRST,LAST
     58       S FIRST=$P(ZARY(WHICH),"^",1)
     59       S LAST=$P(ZARY(WHICH),"^",2)
     60       F I=FIRST:1:LAST  D
     61       . I ZARY(I)?1">"1.E  D  ; NOT A TEST, JUST RUN THE STATEMENT
     62       . . S ZP=$E(ZARY(I),2,$L(ZARY(I)))
     63       . . ;  W ZP,!
     64       . . S ZX=ZP
     65       . . W "RUNNING: "_ZP
     66       . . X ZX
     67       . . W "..SUCCESS: ",WHICH,!
     68       . I ZARY(I)?1"?"1.E  D  ; THIS IS A TEST
     69       . . S ZP=$E(ZARY(I),2,$L(ZARY(I)))
     70       . . S ZX="S ZR="_ZP
     71       . . W "TRYING: "_ZP
     72       . . X ZX
     73       . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),!
     74       . . I '$D(TPASSED) D  ; NOT INITIALIZED YET
     75       . . . S TPASSED=0 S TFAILED=0
     76       . . I ZR S TPASSED=TPASSED+1
     77       . . I 'ZR S TFAILED=TFAILED+1
     78       Q
     79       ;
    9080TEST   ; RUN ALL THE TEST CASES
    9181      N ZTMP
    … …  
    9989      Q
    10090      ;
    101 GTSTS(GTZARY,RTN) ; return an array of test names
    102         N I,J S I="" S I=$O(GTZARY("TESTS",I))
    103         F J=0:0  Q:I=""  D
    104         . D PUSH^GPLXPATH(RTN,I)
    105         . S I=$O(GTZARY("TESTS",I))
    106         Q
    107         ;
    108 TESTALL(RNM) ; RUN ALL THE TESTS
    109         N I,J,TZTMP,TSTS,TOTP,TOTF
    110         S TOTP=0 S TOTF=0
    111         D ZLOAD^GPLUNIT("TZTMP",RNM)
    112         D GTSTS(.TZTMP,"TSTS")
    113         F I=1:1:TSTS(0) D  ;
    114         . S TPASSED=0 S TFAILED=0
    115         . D ZTEST^GPLUNIT(.TZTMP,TSTS(I))
    116         . S TOTP=TOTP+TPASSED
    117         . S TOTF=TOTF+TFAILED
    118         . S $P(TSTS(I),"^",2)=TPASSED
    119         . S $P(TSTS(I),"^",3)=TFAILED
    120         F I=1:1:TSTS(0) D  ;
    121         . W "TEST=> ",$P(TSTS(I),"^",1)
    122         . W " PASSED=>",$P(TSTS(I),"^",2)
    123         . W " FAILED=>",$P(TSTS(I),"^",3),!
    124         W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,!
    125         Q
    126         ;
    12791TLIST(ZARY) ; LIST ALL THE TESTS
    12892     ; THEY ARE MARKED AS ;;><TESTNAME> IN THE TEST CASES

  • /ccr/trunk/p/GPLXPATH.m

    r30 r20  
    189189       . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,!
    190190       . Q
    191        ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INITIALIZE
    192191       D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY
    193192       D BUILD("CPINSTR",CPDEST)
    … …  
    239238       ; XML AT THE END OF THE XPATH POINT
    240239       ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE
    241        N INSBLD,INSTMP
     240       ; N INSBLD,INSTMP
    242241       I DEBUG W "DOING INSERT ",INSXML,INSNEW,INSXPATH,!
    243242       I DEBUG F G1=1:1:@INSXML@(0) W @INSXML@(G1),!
    244        I '$D(@INSXML@(0)) D  Q ; INSERT INTO AN EMPTY ARRAY
    245        . D CP^GPLXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT
     243       I '$D(@INSXML@(0)) D  ; INSERT INTO AN EMPTY ARRAY
     244       . W "DOING A BAD COPY",!
     245       . D CP^GPLXPATH(INSNEW,INXML) ; JUST COPY INTO THE OUTPUT
    246246       I $D(@INSXML@(0)) D  ; IF ORIGINAL ARRAY IS NOT EMPTY
     247       . W "GOT HERE",!
    247248       . I $D(INSXPATH) D  ; XPATH PROVIDED
    248249       . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE
    … …  
    255256       . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
    256257       . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH
    257        . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST
    258        . D CP^GPLXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE
     258       . D BUILD("INSBLD",INSTMP) ; PUT RESULTS IN INDEST
     259       . D CP^GPLXPATH(INSTMP,INSXML) ; COPY BUFFER TO SOURCE
    259260       Q
    260261       ;
    … …  
    333334      Q
    334335      ;
    335 TEST  ; Run all the test cases
    336       D TESTALL^GPLUNIT("GPLXPATH")
     336TEST   ; RUN ALL THE TEST CASES
     337      N ZTMP
     338      D ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
     339      D ZTEST^GPLUNIT(.ZTMP,"ALL")
     340      W "PASSED: ",TPASSED,!
     341      W "FAILED: ",TFAILED,!
     342      W !
     343      ; W "THE TESTS!",!
     344      ; ZWR ZTMP
    337345      Q
    338346      ;
    339 OLDTEST   ; RUN ALL THE TEST CASES
    340         N ZTMP
    341         D ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
    342         D ZTEST^GPLUNIT(.ZTMP,"ALL")
    343         W "PASSED: ",TPASSED,!
    344         W "FAILED: ",TFAILED,!
    345         W !
    346         ; W "THE TESTS!",!
    347         ; ZWR ZTMP
    348         Q
    349         ;
    350347ZTEST(WHICH) ; RUN ONE SET OF TESTS
    351         N ZTMP
    352         S DEBUG=1
    353         D ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
    354         D ZTEST^GPLUNIT(.ZTMP,WHICH)
    355         Q
    356         ;
     348      N ZTMP
     349      D ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
     350      D ZTEST^GPLUNIT(.ZTMP,WHICH)
     351      Q
     352      ;
    357353TLIST ; LIST THE TESTS
    358354      N ZTMP
    … …  
    469465;;>>>D ZTEST^GPLXPATH("INITXML")
    470466;;>>>D QOPEN^GPLXPATH("GBL","GXML")
    471 ;;>>?$P(GBL(1),";",3)=12
     467;;>>?$P(GBL(1),"^",3)=12
    472468;;>>>D BUILD^GPLXPATH("GBL","G2")
    473469;;>>?G2(G2(0))="</SECOND>"
    … …  
    476472;;>>>D ZTEST^GPLXPATH("INITXML")
    477473;;>>>D QOPEN^GPLXPATH("GBL","GXML","//FIRST/SECOND")
    478 ;;>>?$P(GBL(1),";",3)=11
     474;;>>?$P(GBL(1),"^",3)=12
    479475;;>>>D BUILD^GPLXPATH("GBL","G2")
    480476;;>>?G2(G2(0))="</SECOND>"
    … …  
    483479;;>>>D ZTEST^GPLXPATH("INITXML")
    484480;;>>>D QCLOSE^GPLXPATH("GBL","GXML")
    485 ;;>>?$P(GBL(1),";",3)=13
     481;;>>?$P(GBL(1),"^",3)=13
    486482;;>>>D BUILD^GPLXPATH("GBL","G2")
    487483;;>>?G2(G2(0))="</FIRST>"
    … …  
    490486;;>>>D ZTEST^GPLXPATH("INITXML")
    491487;;>>>D QCLOSE^GPLXPATH("GBL","GXML","//FIRST/SECOND/THIRD")
    492 ;;>>?$P(GBL(1),";",3)=13
     488;;>>?$P(GBL(1),"^",3)=13
    493489;;>>>D BUILD^GPLXPATH("GBL","G2")
    494490;;>>?G2(G2(0))="</FIRST>"
    … …  
    498494;;>>>D ZTEST^GPLXPATH("INITXML")
    499495;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2")
    500 ;;>>>D INSERT^GPLXPATH("GXML","G2","//FIRST/SECOND/THIRD")
    501 ;;>>>D INSERT^GPLXPATH("G3","G2","//")
    502 ;;>>?G2(1)=GXML(9)
     496;;>>>D INSERT^GPLXPATH("GXML","G2","G3","//FIRST/SECOND/THIRD")
     497;;>>>D INSERT^GPLXPATH("G3","G2","G4","//FIRST/SECOND/THIRD")
     498;;>>?G2(1)=G3(9)
    503499;;><REPLACE>
    504500;;>>>K G2,GBL,G3
Note: See TracChangeset for help on using the changeset viewer.