Changeset 1544 for ccr/trunk/p/C0CSUB1.m


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/C0CSUB1.m

    r1336 r1544  
    1 C0CSUB1   ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 38
    3  ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  W "This is the CCR SUBSCRIPTIONN Utility Library ",!
    21  Q
    22  ;
    23 CHK1(DFN) ; ADD THE CHECKSUM FOR ONE PATIENT
    24  ;
    25  S C0CCHK=$NA(^TMP("C0CRIM","CHKSUM"))
    26  S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE
    27  S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE
    28  S C0CSFC=177.1012 ; FILE NUMBER FOR CHECKSUM SUBFILE
    29  S C0CSFDC=177.10121 ; FILE NUMBER FOR DOMAIN CHECKSUMS
    30  S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT
    31  K C0CFDA
    32  S C0CALL=$G(@C0CCHK@(DFN,"ALL"))
    33  I C0CALL'="" S C0CFDA(C0CSFC,"?+1,"_C0CPAT_",",.01)=C0CALL
    34  E  Q ; NO CHECKSUMS FOR THISPATIENT
    35  D UPDIE
    36  N C0CJ S C0CJ=""
    37  F  S C0CJ=$O(@C0CCHK@(DFN,"DOMAIN",C0CJ)) Q:C0CJ=""  D  ; FOR EACH DOMAIN
    38  . S C0CD=$O(^C0CDIC(170.101,"B",C0CJ,""))
    39  . W C0CJ," ",C0CD,!
    40  . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",.01)=C0CD
    41  . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",1)=@C0CCHK@(DFN,"DOMAIN",C0CJ)
    42  . D UPDIE
    43  Q
    44  ;
    45 SUBALL ; SUBSCRIBE ALL PATIENTS IN CCR GLOBALS TO SUBCRIBER 1
    46  ;
    47  S C0CGLB=$NA(^TMP("C0CRIM","VARS"))
    48  S C0CI=""
    49  F  S C0CI=$O(@C0CGLB@(C0CI)) Q:C0CI=""  D  ; FOR EACH PATIENT
    50  . D SUB1(C0CI,1) ;SUBSCIRBE THEM TO EPCRN
    51  Q
    52  ;
    53 SUB1(DFN,C0CSS) ; SUBSCRIBE ONE PATIENT TO SUBSCRIBER C0CSS
    54  ;
    55  S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE
    56  S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE
    57  S C0CSFC=177.10121 ; FILE NUMBER FOR CHECKSUMS
    58  S C0CSSF=177.201 ; FILE NUMBER FOR SUBSCRIBER FILE
    59  K C0CFDA
    60  S C0CFDA(C0CSF,"+1,",.01)=DFN
    61  D UPDIE ; ADD THE PATIENT
    62  S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT
    63  S C0CFDA(C0CSFS,"+1,"_C0CPAT_",",.01)=C0CSS ; C0CSS IS A POINTER
    64  D UPDIE ; ADD THE SUBSCRIPTION
    65  D CHK1(DFN) ; ADD THE CHECKSUMS
    66  Q
    67  ;
    68 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
    69  K ZERR
    70  D CLEAN^DILF
    71  D UPDATE^DIE("","C0CFDA","","ZERR")
    72  I $D(ZERR) D  ;
    73  . W "ERROR",!
    74  . ZWR ZERR
    75  . B
    76  K C0CFDA
    77  Q
    78  ;
    79 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
    80  ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
    81  ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
    82  ;
    83  N ZCCRD,ZVARN,C0CFDA2
    84  S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
    85  S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    86  I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
    87  . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
    88  . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
    89  . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
    90  . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
    91  . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
    92  . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
    93  . I $D(ZERR) D  ; LAYGO ERROR
    94  . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
    95  . E  D  ;
    96  . . D CLEAN^DILF ; CLEAN UP
    97  . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    98  . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
    99  Q ZVARN
    100  ;
    101 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
    102  ; TO SET TO VALUE C0CSV.
    103  ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
    104  ; C0CSN,C0CSV ARE PASSED BY VALUE
    105  ;
    106  N C0CSI,C0CSJ
    107  S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
    108  S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
    109  S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
    110  Q
    111 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
    112  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
    113  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    114  I '$D(ZTAB) S ZTAB="C0CA"
    115  N ZR
    116  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
    117  E  S ZR=""
    118  Q ZR
    119 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
    120  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
    121  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    122  I '$D(ZTAB) S ZTAB="C0CA"
    123  N ZR
    124  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
    125  E  S ZR=""
    126  Q ZR
    127  ;
    128 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
    129  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
    130  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    131  I '$D(ZTAB) S ZTAB="C0CA"
    132  N ZR
    133  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
    134  E  S ZR=""
    135  Q ZR
    136  ;
     1C0CSUB1   ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08
     2        ;;1.2;C0C;;May 11, 2012;Build 47
     3        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        W "This is the CCR SUBSCRIPTIONN Utility Library ",!
     21        Q
     22        ;
     23CHK1(DFN)       ; ADD THE CHECKSUM FOR ONE PATIENT
     24        ;
     25        S C0CCHK=$NA(^TMP("C0CRIM","CHKSUM"))
     26        S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE
     27        S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE
     28        S C0CSFC=177.1012 ; FILE NUMBER FOR CHECKSUM SUBFILE
     29        S C0CSFDC=177.10121 ; FILE NUMBER FOR DOMAIN CHECKSUMS
     30        S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT
     31        K C0CFDA
     32        S C0CALL=$G(@C0CCHK@(DFN,"ALL"))
     33        I C0CALL'="" S C0CFDA(C0CSFC,"?+1,"_C0CPAT_",",.01)=C0CALL
     34        E  Q ; NO CHECKSUMS FOR THISPATIENT
     35        D UPDIE
     36        N C0CJ S C0CJ=""
     37        F  S C0CJ=$O(@C0CCHK@(DFN,"DOMAIN",C0CJ)) Q:C0CJ=""  D  ; FOR EACH DOMAIN
     38        . S C0CD=$O(^C0CDIC(170.101,"B",C0CJ,""))
     39        . W C0CJ," ",C0CD,!
     40        . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",.01)=C0CD
     41        . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",1)=@C0CCHK@(DFN,"DOMAIN",C0CJ)
     42        . D UPDIE
     43        Q
     44        ;
     45SUBALL  ; SUBSCRIBE ALL PATIENTS IN CCR GLOBALS TO SUBCRIBER 1
     46        ;
     47        S C0CGLB=$NA(^TMP("C0CRIM","VARS"))
     48        S C0CI=""
     49        F  S C0CI=$O(@C0CGLB@(C0CI)) Q:C0CI=""  D  ; FOR EACH PATIENT
     50        . D SUB1(C0CI,1) ;SUBSCIRBE THEM TO EPCRN
     51        Q
     52        ;
     53SUB1(DFN,C0CSS) ; SUBSCRIBE ONE PATIENT TO SUBSCRIBER C0CSS
     54        ;
     55        S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE
     56        S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE
     57        S C0CSFC=177.10121 ; FILE NUMBER FOR CHECKSUMS
     58        S C0CSSF=177.201 ; FILE NUMBER FOR SUBSCRIBER FILE
     59        K C0CFDA
     60        S C0CFDA(C0CSF,"+1,",.01)=DFN
     61        D UPDIE ; ADD THE PATIENT
     62        S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT
     63        S C0CFDA(C0CSFS,"+1,"_C0CPAT_",",.01)=C0CSS ; C0CSS IS A POINTER
     64        D UPDIE ; ADD THE SUBSCRIPTION
     65        D CHK1(DFN) ; ADD THE CHECKSUMS
     66        Q
     67        ;
     68UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
     69        K ZERR
     70        D CLEAN^DILF
     71        D UPDATE^DIE("","C0CFDA","","ZERR")
     72        I $D(ZERR) D  ;
     73        . W "ERROR",!
     74        . ZWR ZERR
     75        . B
     76        K C0CFDA
     77        Q
     78        ;
     79VARPTR(ZVAR,ZTYP)       ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
     80        ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
     81        ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
     82        ;
     83        N ZCCRD,ZVARN,C0CFDA2
     84        S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
     85        S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     86        I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
     87        . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
     88        . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
     89        . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
     90        . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
     91        . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
     92        . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
     93        . I $D(ZERR) D  ; LAYGO ERROR
     94        . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
     95        . E  D  ;
     96        . . D CLEAN^DILF ; CLEAN UP
     97        . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     98        . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
     99        Q ZVARN
     100        ;
     101SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
     102        ; TO SET TO VALUE C0CSV.
     103        ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
     104        ; C0CSN,C0CSV ARE PASSED BY VALUE
     105        ;
     106        N C0CSI,C0CSJ
     107        S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
     108        S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
     109        S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
     110        Q
     111ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
     112        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
     113        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     114        I '$D(ZTAB) S ZTAB="C0CA"
     115        N ZR
     116        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
     117        E  S ZR=""
     118        Q ZR
     119ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
     120        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
     121        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     122        I '$D(ZTAB) S ZTAB="C0CA"
     123        N ZR
     124        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
     125        E  S ZR=""
     126        Q ZR
     127        ;
     128ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
     129        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
     130        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     131        I '$D(ZTAB) S ZTAB="C0CA"
     132        N ZR
     133        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
     134        E  S ZR=""
     135        Q ZR
     136        ;
Note: See TracChangeset for help on using the changeset viewer.