Changeset 1330 for ccr/branches/ohum/p/C0CSUB1.m
- Timestamp:
- Jan 3, 2012, 11:45:29 PM (12 years ago)
- File:
-
- 1 edited
-
ccr/branches/ohum/p/C0CSUB1.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
ccr/branches/ohum/p/C0CSUB1.m
r1329 r1330 1 C0CSUB1 2 ;;1.0;C0C;;May 19, 2009;Build 38 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 CHK1(DFN) 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 SUBALL 46 47 48 49 50 51 52 53 SUB1(DFN,C0CSS) 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 UPDIE 69 70 71 72 73 74 75 76 77 78 79 VARPTR(ZVAR,ZTYP) 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 SETFDA(C0CSN,C0CSV) 102 103 104 105 106 107 108 109 110 111 ZFILE(ZFN,ZTAB) 112 113 114 115 116 117 118 119 ZFIELD(ZFN,ZTAB) 120 121 122 123 124 125 126 127 128 ZVALUE(ZFN,ZTAB) 129 130 131 132 133 134 135 136 1 C0CSUB1 ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 1 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 ;
Note:
See TracChangeset
for help on using the changeset viewer.
