Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m
r613 r623 1 PXRMEXPU ; SLC/PKR - Utilities for packing and unpacking repository entries. ;09/10/2007 2 ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 3 ;================================================== 4 BTTABLE(DIQOUT,IENROOT,TTABLE) ;Build the DIQOUT to FDA iens translation table. 5 N FILENUM,IENS,IENT,IND,UP 6 S FILENUM=$O(DIQOUT("")) 7 I FILENUM="" Q 8 ;DBIA #2631 9 S UP=$G(^DD(FILENUM,0,"UP")) 10 ;Top level file in DIQOUT should not have an up node. 11 I UP="" D 12 . S IENS=$O(DIQOUT(FILENUM,"")),IND=+IENS 13 . S TTABLE(FILENUM,IENS)="+"_IENS 14 E D Q 15 . W !,"BTTABLE^PXRMEXPU - DIQOUT problem, do not have correct top level" 16 ; 17 F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D 18 . S UP=$G(^DD(FILENUM,0,"UP")) 19 . S IENS="" 20 . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D 21 .. S IND=IND+1 22 .. S IENT=$P(IENS,",",2,99) 23 .. S TTABLE(FILENUM,IENS)="+"_IND_","_TTABLE(UP,IENT) 24 .. S IENROOT(IND)=$P(IENS,",",1) 25 Q 26 ; 27 ;================================================== 28 CLDIQOUT(DIQOUT) ;Clean up DIQOUT remove null entries and change .01's 29 ;to the resolved form. 30 N ABBR,IENS,INTERNAL,FIELD,FILENUM,LINE 31 N PTRTO,ROOT,TYPE,WPLCNT,VLIST,VPTRLIST 32 S FILENUM="" 33 F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D 34 . K TYPE,VPTRLIST 35 . S IENS="" 36 . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D 37 .. S FIELD="" 38 .. F S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD="" D 39 ...;If there is no data then don't keep this entry. 40 ... I DIQOUT(FILENUM,IENS,FIELD)="" K DIQOUT(FILENUM,IENS,FIELD) Q 41 ...;Get the field type, if it is a variable-pointer then set up 42 ...;the resolved form. 43 ... I '$D(TYPE(FILENUM,FIELD)) S TYPE(FILENUM,FIELD)=$$GET1^DID(FILENUM,FIELD,"","TYPE") 44 ... S PTRTO=$S(TYPE(FILENUM,FIELD)="POINTER":$$GET1^DID(FILENUM,FIELD,"","POINTER"),1:"") 45 ... ;Remove pointers to file 200. 46 ... I PTRTO="VA(200," S DIQOUT(FILENUM,IENS,FIELD)="" Q 47 ...;If the field's type is COMPUTED then don't transport it. 48 ... I TYPE(FILENUM,FIELD)="COMPUTED" K DIQOUT(FILENUM,IENS,FIELD) Q 49 ... I TYPE(FILENUM,FIELD)="VARIABLE-POINTER" D 50 .... I '$D(VPTRLIST(FILENUM,FIELD)) D 51 ..... K VLIST 52 ..... D BLDRLIST^PXRMVPTR(FILENUM,FIELD,.VLIST) 53 ..... M VPTRLIST(FILENUM,FIELD)=VLIST 54 .... S INTERNAL=$$GET1^DIQ(FILENUM,IENS,FIELD,"I") 55 .... S (PTRTO,ROOT)=$P(INTERNAL,";",2) 56 .... S ABBR=$P(VPTRLIST(FILENUM,FIELD,ROOT),U,4) 57 .... S DIQOUT(FILENUM,IENS,FIELD)=ABBR_"."_DIQOUT(FILENUM,IENS,FIELD) 58 ... I TYPE(FILENUM,FIELD)="WORD-PROCESSING" D 59 .... S (LINE,WPLCNT)=0 60 .... F S LINE=$O(DIQOUT(FILENUM,IENS,FIELD,LINE)) Q:LINE="" D 61 ..... S WPLCNT=WPLCNT+1 62 .... I WPLCNT>0 S DIQOUT(FILENUM,IENS,FIELD)="WP-start~"_WPLCNT 63 .... E K DIQOUT(FILENUM,IENS,FIELD) 64 ...;For fields that point to files 80 and 80.1 we have to append a space 65 ...;so FileMan can resolve the pointers when installing a component. 66 ... I PTRTO["ICD" S DIQOUT(FILENUM,IENS,FIELD)=DIQOUT(FILENUM,IENS,FIELD)_" " 67 Q 68 ; 69 ;================================================== 70 CONTOFDA(DIQOUT,IENROOT) ;Convert the iens from the form 71 ;returned by GETS^DIQ to the FDA laygo form used by UPDATE^DIE. 72 ;DIQOUT contains the GETS^DIQ output. If any of the fields are 73 ;variable pointers change them to the resolved form. 74 N IENS,IENSA,FIELD,FILENUM,TTABLE,TYPE 75 ;Clean up DIQOUT remove null entries and change .01's to the resolved 76 ;form. 77 D CLDIQOUT(.DIQOUT) 78 ;Convert the iens to the adding FDA form . 79 D BTTABLE(.DIQOUT,.IENROOT,.TTABLE) 80 S FILENUM="" 81 F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D 82 . S IENS="" 83 . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D 84 .. S IENSA=TTABLE(FILENUM,IENS) 85 .. S FIELD="" 86 .. F S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD="" D 87 ... M DIQOUT(FILENUM,IENSA,FIELD)=DIQOUT(FILENUM,IENS,FIELD) 88 .. K DIQOUT(FILENUM,IENS) 89 Q 90 ; 91 ;================================================== 92 GDIQF(LIST,NUM,TMPIND,SERROR) ;Save file entries into ^TMP(TMPIND,$J). 93 N CSUM,DIQOUT,IENROOT,IND,FIELD,FILENAME,IENS,MSG,PT01,TEMP 94 S ^TMP(TMPIND,$J,"NUMF")=NUM 95 F IND=1:1:NUM D 96 . S TEMP=LIST(IND) 97 . S FILENAME=$P(TEMP,U,1) 98 . S FILENUM=$P(TEMP,U,2) 99 . S IEN=$P(TEMP,U,3) 100 . K DIQOUT,IENROOT 101 .;If the file entry is ok to install then get the entire entry, 102 .;otherwise just get the .01. 103 . I $$FOKTI^PXRMEXFI(FILENUM) S FIELD="**" 104 . E S FIELD=.01 105 . D GETS^DIQ(FILENUM,IEN,FIELD,"N","DIQOUT","MSG") 106 . I $D(MSG) D Q 107 .. S SERROR=1,IND=NUM 108 .. N ETEXT 109 .. S ETEXT="GETS^DIQ failed for "_FILENAME_", ien="_IEN_";" 110 .. W !,ETEXT 111 .. W !,"it returned the following error:" 112 .. D AWRITE^PXRMUTIL("MSG") 113 .. H 2 114 .. K MSG 115 .;Remove edit history from all reminder files. 116 . D RMEH(FILENUM,.DIQOUT) 117 .;Convert the iens to the FDA adding form. 118 . D CONTOFDA(.DIQOUT,.IENROOT) 119 . S CSUM=$$DIQOUTCS^PXRMEXCS(.DIQOUT) 120 . S ^TMP("PXRMEXCS",$J,IND,FILENAME)=CSUM 121 .;Load the converted DIQOUT into TMP. 122 . M ^TMP(TMPIND,$J,IND,FILENAME)=DIQOUT 123 . M ^TMP(TMPIND,$J,IND,FILENAME_"_IENROOT")=IENROOT 124 Q 125 ; 126 ;================================================== 127 GETREM(ACTION) ;Get the reminder to save. 128 N DIC,DUOUT,X,Y 129 S DIC="^PXD(811.9," 130 S DIC(0)="AEMQ" 131 S DIC("A")="Select Reminder Definition to "_ACTION_": " 132 D ^DIC 133 Q Y 134 ; 135 ;================================================== 136 GRTN(LIST,NUM,TMPIND,SERROR) ;Save routines into ^TMP(TMPIND,$J). 137 N DIF,IEN,IND,RA,TEMP,X,XCNP 138 S ^TMP(TMPIND,$J,"NUMR")=NUM 139 S X="" 140 F IND=1:1:NUM D 141 .;Make sure the routine exists. 142 . S X=LIST(IND) 143 . X ^%ZOSF("TEST") 144 . I $T D 145 .. K RA 146 .. S DIF="RA(" 147 .. S XCNP=0 148 .. X ^%ZOSF("LOAD") 149 .. S ^TMP("PXRMEXCS",$J,"ROUTINE",X)=$$ROUTINE^PXRMEXCS(.RA) 150 .. M ^TMP(TMPIND,$J,"ROUTINE",X)=RA 151 . E D 152 .. S SERROR=1 153 .. W !,"Warning could not find routine ",X 154 .. H 2 155 Q 156 ; 157 ;================================================== 158 RMEH(FILENUM,DIQOUT,NOSTUB) ;Clear the edit history from all reminder files. 159 ;Leave a stub so it can be filled in when the file is installed. 160 I (FILENUM<800)!(FILENUM>811.9) Q 161 N IENS,SFN,TARGET 162 ;Edit History is stored in node 110 for all files, get the 163 ;subfile number. 164 D FIELD^DID(FILENUM,110,"","SPECIFIER","TARGET") 165 S SFN=+$G(TARGET("SPECIFIER")) 166 I SFN=0 Q 167 ;Clean out the history. 168 S IENS="" 169 F S IENS=$O(DIQOUT(SFN,IENS)) Q:IENS="" K DIQOUT(SFN,IENS) 170 ;Create a stub for the install. 171 I $G(NOSTUB) Q 172 S IENS="1,"_$O(DIQOUT(FILENUM,"")) 173 S DIQOUT(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z") 174 S DIQOUT(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01) 175 S DIQOUT(SFN,IENS,2)="DIQOUT("_SFN_","_IENS_"2)" 176 S DIQOUT(SFN,IENS,2,1)="Exchange Stub" 177 Q 178 ; 179 ;================================================== 180 UPDATE(SUCCESS,FDA,FDAIEN) ;Call to add new entries to the repository. 181 N MSG 182 ;Try to eliminate gaps in the repository. 183 S $P(^PXD(811.8,0),U,3)=0 184 D UPDATE^DIE("E","FDA","FDAIEN","MSG") 185 I $D(MSG) D 186 . N DATE,RNAME 187 . S SUCCESS=0 188 . W !,"The update failed, UPDATE^DIE returned the following error message:" 189 . D AWRITE^PXRMUTIL("MSG") 190 . S RNAME=FDA(811.8,"+1,",.01) 191 . S DATE=FDA(811.8,"+1,",.03) 192 . W !!,"Exchange File entry ",RNAME," date packed ",DATE," did not get stored!" 193 . W !,"Examine the above error message for the reason.",! 194 . H 2 195 E S SUCCESS=1 196 Q 197 ; 1 PXRMEXPU ; SLC/PKR - Utilities for packing and unpacking repository entries. ;12/22/2004 2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 3 ;================================================== 4 BTTABLE(DIQOUT,IENROOT,TTABLE) ;Build the DIQOUT to FDA iens translation table. 5 N FILENUM,IENS,IENT,IND,UP 6 S FILENUM=$O(DIQOUT("")) 7 I FILENUM="" Q 8 ;DBIA #2631 9 S UP=$G(^DD(FILENUM,0,"UP")) 10 ;Top level file in DIQOUT should not have an up node. 11 I UP="" D 12 . S IENS=$O(DIQOUT(FILENUM,"")),IND=+IENS 13 . S TTABLE(FILENUM,IENS)="+"_IENS 14 E D Q 15 . W !,"BTTABLE^PXRMEXPU - DIQOUT problem do not have correct top level" 16 ; 17 F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D 18 . S UP=$G(^DD(FILENUM,0,"UP")) 19 . S IENS="" 20 . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D 21 .. S IND=IND+1 22 .. S IENT=$P(IENS,",",2,99) 23 .. S TTABLE(FILENUM,IENS)="+"_IND_","_TTABLE(UP,IENT) 24 .. S IENROOT(IND)=$P(IENS,",",1) 25 Q 26 ; 27 ;================================================== 28 CLDIQOUT(DIQOUT) ;Clean up DIQOUT remove null entries and change .01's 29 ;to the resolved form. 30 N ABBR,IENS,INTERNAL,FIELD,FILENUM,LINE 31 N PTRTO,ROOT,TYPE,WPLCNT,VLIST,VPTRLIST 32 S FILENUM="" 33 F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D 34 . K TYPE,VPTRLIST 35 . S IENS="" 36 . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D 37 .. S FIELD="" 38 .. F S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD="" D 39 ...;If there is no data then don't keep this entry. 40 ... I DIQOUT(FILENUM,IENS,FIELD)="" K DIQOUT(FILENUM,IENS,FIELD) Q 41 ...;Get the field type, if it is a variable-pointer then set up 42 ...;the resolved form. 43 ... I '$D(TYPE(FILENUM,FIELD)) S TYPE(FILENUM,FIELD)=$$GET1^DID(FILENUM,FIELD,"","TYPE") 44 ... S PTRTO=$S(TYPE(FILENUM,FIELD)="POINTER":$$GET1^DID(FILENUM,FIELD,"","POINTER"),1:"") 45 ...;If the field's type is COMPUTED then don't transport it. 46 ... I TYPE(FILENUM,FIELD)="COMPUTED" K DIQOUT(FILENUM,IENS,FIELD) Q 47 ... I TYPE(FILENUM,FIELD)="VARIABLE-POINTER" D 48 .... I '$D(VPTRLIST(FILENUM,FIELD)) D 49 ..... K VLIST 50 ..... D BLDRLIST^PXRMVPTR(FILENUM,FIELD,.VLIST) 51 ..... M VPTRLIST(FILENUM,FIELD)=VLIST 52 .... S INTERNAL=$$GET1^DIQ(FILENUM,IENS,FIELD,"I") 53 .... S (PTRTO,ROOT)=$P(INTERNAL,";",2) 54 .... S ABBR=$P(VPTRLIST(FILENUM,FIELD,ROOT),U,4) 55 .... S DIQOUT(FILENUM,IENS,FIELD)=ABBR_"."_DIQOUT(FILENUM,IENS,FIELD) 56 ... I TYPE(FILENUM,FIELD)="WORD-PROCESSING" D 57 .... S (LINE,WPLCNT)=0 58 .... F S LINE=$O(DIQOUT(FILENUM,IENS,FIELD,LINE)) Q:LINE="" D 59 ..... S WPLCNT=WPLCNT+1 60 .... I WPLCNT>0 S DIQOUT(FILENUM,IENS,FIELD)="WP-start~"_WPLCNT 61 .... E K DIQOUT(FILENUM,IENS,FIELD) 62 ...;For fields that point to files 80 and 80.1 we have to append a space 63 ...;so FileMan can resolve the pointers when installing a component. 64 ... I PTRTO["ICD" S DIQOUT(FILENUM,IENS,FIELD)=DIQOUT(FILENUM,IENS,FIELD)_" " 65 Q 66 ; 67 ;================================================== 68 CONTOFDA(DIQOUT,IENROOT) ;Convert the iens from the form 69 ;returned by GETS^DIQ to the FDA laygo form used by UPDATE^DIE. 70 ;DIQOUT contains the GETS^DIQ output. If any of the fields are 71 ;variable pointers change them to the resolved form. 72 N IENS,IENSA,FIELD,FILENUM,TTABLE,TYPE 73 ;Clean up DIQOUT remove null entries and change .01's to the resolved 74 ;form. 75 D CLDIQOUT(.DIQOUT) 76 ;Convert the iens to the adding FDA form . 77 D BTTABLE(.DIQOUT,.IENROOT,.TTABLE) 78 S FILENUM="" 79 F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D 80 . S IENS="" 81 . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D 82 .. S IENSA=TTABLE(FILENUM,IENS) 83 .. S FIELD="" 84 .. F S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD="" D 85 ... M DIQOUT(FILENUM,IENSA,FIELD)=DIQOUT(FILENUM,IENS,FIELD) 86 .. K DIQOUT(FILENUM,IENS) 87 Q 88 ; 89 ;================================================== 90 GDIQF(LIST,NUM,TMPIND,SERROR) ;Save file entries into ^TMP(TMPIND,$J). 91 N DIQOUT,IENROOT,IND,FIELD,FILENAME,IENS,MSG,PT01,TEMP 92 S ^TMP(TMPIND,$J,"NUMF")=NUM 93 F IND=1:1:NUM D 94 . S TEMP=LIST(IND) 95 . S FILENAME=$P(TEMP,U,1) 96 . S FILENUM=$P(TEMP,U,2) 97 . S IEN=$P(TEMP,U,3) 98 . K DIQOUT,IENROOT 99 .;If the file entry is ok to install then get the entire entry, 100 .;otherwise just get the .01. 101 . I $$FOKTI^PXRMEXFI(FILENUM) S FIELD="**" 102 . E S FIELD=.01 103 . D GETS^DIQ(FILENUM,IEN,FIELD,"","DIQOUT","MSG") 104 . I $D(MSG) D Q 105 .. S SERROR=1,IND=NUM 106 .. N ETEXT 107 .. S ETEXT="GETS^DIQ failed for "_FILENAME_", ien="_IEN_";" 108 .. W !,ETEXT 109 .. W !,"it returned the following error:" 110 .. D AWRITE^PXRMUTIL("MSG") 111 .. H 2 112 .. K MSG 113 .;Remove edit history from all reminder files. 114 . D RMEH(FILENUM,.DIQOUT) 115 .;Convert the iens to the FDA adding form. 116 . D CONTOFDA(.DIQOUT,.IENROOT) 117 .;Load the converted DIQOUT into TMP. 118 . M ^TMP(TMPIND,$J,IND,FILENAME)=DIQOUT 119 . M ^TMP(TMPIND,$J,IND,FILENAME_"_IENROOT")=IENROOT 120 Q 121 ; 122 ;================================================== 123 GETREM(ACTION) ;Get the reminder to save. 124 N DIC,DUOUT,X,Y 125 S DIC="^PXD(811.9," 126 S DIC(0)="AEMQ" 127 S DIC("A")="Select Reminder Definition to "_ACTION_": " 128 D ^DIC 129 Q Y 130 ; 131 ;================================================== 132 GRTN(LIST,NUM,TMPIND,SERROR) ;Save routines into ^TMP(TMPIND,$J). 133 N DIF,IEN,IND,TEMP,X,XCNP 134 S ^TMP(TMPIND,$J,"NUMR")=NUM 135 S X="" 136 F IND=1:1:NUM D 137 .;Make sure the routine exists. 138 . S X=LIST(IND) 139 . X ^%ZOSF("TEST") 140 . I $T D 141 .. S DIF="^TMP(TMPIND,$J,""ROUTINE"","""_X_"""," 142 .. S XCNP=0 143 .. X ^%ZOSF("LOAD") 144 . E D 145 .. S SERROR=1 146 .. W !,"Warning could not find routine ",X 147 .. H 2 148 Q 149 ; 150 ;================================================== 151 RMEH(FILENUM,DIQOUT) ;Clear the edit history from all reminder files. 152 ;Leave a stub so it can be filled in when the file is installed. 153 I (FILENUM<800)!(FILENUM>811.9) Q 154 N IEN,SFN,TARGET 155 ;Edit History is stored in node 110 for all files, get the 156 ;subfile number. 157 D FIELD^DID(FILENUM,110,"","SPECIFIER","TARGET") 158 S SFN=+$G(TARGET("SPECIFIER")) 159 I SFN=0 Q 160 ;Clean out the history. 161 S IENS="" 162 F S IENS=$O(DIQOUT(SFN,IENS)) Q:IENS="" K DIQOUT(SFN,IENS) 163 ;Create a stub for the install. 164 S IENS="1,"_$O(DIQOUT(FILENUM,"")) 165 S DIQOUT(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z") 166 S DIQOUT(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01) 167 S DIQOUT(SFN,IENS,2)="DIQOUT("_SFN_","_IENS_"2)" 168 S DIQOUT(SFN,IENS,2,1)="Exchange Stub" 169 Q 170 ; 171 ;================================================== 172 UPDATE(SUCCESS,FDA,FDAIEN) ;Call to add new entries to the repository. 173 N MSG 174 ;Try to eliminate gaps in the repository. 175 S $P(^PXD(811.8,0),U,3)=0 176 D UPDATE^DIE("E","FDA","FDAIEN","MSG") 177 I $D(MSG) D 178 . N DATE,RNAME 179 . S SUCCESS=0 180 . W !,"The update failed, UPDATE^DIE returned the following error message:" 181 . D AWRITE^PXRMUTIL("MSG") 182 . S RNAME=FDA(811.8,"+1,",.01) 183 . S DATE=FDA(811.8,"+1,",.03) 184 . W !!,"Exchange File entry ",RNAME," date packed ",DATE," did not get stored!" 185 . W !,"Examine the above error message for the reason.",! 186 . H 2 187 E S SUCCESS=1 188 Q 189 ;
Note:
See TracChangeset
for help on using the changeset viewer.
