source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m@ 1714

PXRMEXPU ; SLC/PKR - Utilities for packing and unpacking repository entries. ;12/22/2004
 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
 ;==================================================
BTTABLE(DIQOUT,IENROOT,TTABLE) ;Build the DIQOUT to FDA iens translation table.
 N FILENUM,IENS,IENT,IND,UP
 S FILENUM=$O(DIQOUT(""))
 I FILENUM="" Q
 ;DBIA #2631
 S UP=$G(^DD(FILENUM,0,"UP"))
 ;Top level file in DIQOUT should not have an up node.
 I UP="" D
 . S IENS=$O(DIQOUT(FILENUM,"")),IND=+IENS
 . S TTABLE(FILENUM,IENS)="+"_IENS
 E  D  Q
 . W !,"BTTABLE^PXRMEXPU - DIQOUT problem do not have correct top level"
 ;
 F  S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM=""  D
 . S UP=$G(^DD(FILENUM,0,"UP"))
 . S IENS=""
 . F  S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS=""  D
 .. S IND=IND+1
 .. S IENT=$P(IENS,",",2,99)
 .. S TTABLE(FILENUM,IENS)="+"_IND_","_TTABLE(UP,IENT)
 .. S IENROOT(IND)=$P(IENS,",",1)
 Q
 ;
 ;==================================================
CLDIQOUT(DIQOUT) ;Clean up DIQOUT remove null entries and change .01's
 ;to the resolved form.
 N ABBR,IENS,INTERNAL,FIELD,FILENUM,LINE
 N PTRTO,ROOT,TYPE,WPLCNT,VLIST,VPTRLIST
 S FILENUM=""
 F  S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM=""  D
 . K TYPE,VPTRLIST
 . S IENS=""
 . F  S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS=""  D
 .. S FIELD=""
 .. F  S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD=""  D
 ...;If there is no data then don't keep this entry.
 ... I DIQOUT(FILENUM,IENS,FIELD)="" K DIQOUT(FILENUM,IENS,FIELD) Q
 ...;Get the field type, if it is a variable-pointer then set up
 ...;the resolved form.
 ... I '$D(TYPE(FILENUM,FIELD)) S TYPE(FILENUM,FIELD)=$$GET1^DID(FILENUM,FIELD,"","TYPE")
 ... S PTRTO=$S(TYPE(FILENUM,FIELD)="POINTER":$$GET1^DID(FILENUM,FIELD,"","POINTER"),1:"")
 ...;If the field's type is COMPUTED then don't transport it.
 ... I TYPE(FILENUM,FIELD)="COMPUTED" K DIQOUT(FILENUM,IENS,FIELD) Q
 ... I TYPE(FILENUM,FIELD)="VARIABLE-POINTER" D
 .... I '$D(VPTRLIST(FILENUM,FIELD)) D
 ..... K VLIST
 ..... D BLDRLIST^PXRMVPTR(FILENUM,FIELD,.VLIST)
 ..... M VPTRLIST(FILENUM,FIELD)=VLIST
 .... S INTERNAL=$$GET1^DIQ(FILENUM,IENS,FIELD,"I")
 .... S (PTRTO,ROOT)=$P(INTERNAL,";",2)
 .... S ABBR=$P(VPTRLIST(FILENUM,FIELD,ROOT),U,4)
 .... S DIQOUT(FILENUM,IENS,FIELD)=ABBR_"."_DIQOUT(FILENUM,IENS,FIELD)
 ... I TYPE(FILENUM,FIELD)="WORD-PROCESSING" D
 .... S (LINE,WPLCNT)=0
 .... F  S LINE=$O(DIQOUT(FILENUM,IENS,FIELD,LINE)) Q:LINE=""  D
 ..... S WPLCNT=WPLCNT+1
 .... I WPLCNT>0 S DIQOUT(FILENUM,IENS,FIELD)="WP-start~"_WPLCNT
 .... E  K DIQOUT(FILENUM,IENS,FIELD)
 ...;For fields that point to files 80 and 80.1 we have to append a space
 ...;so FileMan can resolve the pointers when installing a component.
 ... I PTRTO["ICD" S DIQOUT(FILENUM,IENS,FIELD)=DIQOUT(FILENUM,IENS,FIELD)_" "
 Q
 ;
 ;==================================================
CONTOFDA(DIQOUT,IENROOT) ;Convert the iens from the form
 ;returned by GETS^DIQ to the FDA laygo form used by UPDATE^DIE.
 ;DIQOUT contains the GETS^DIQ output. If any of the fields are
 ;variable pointers change them to the resolved form.
 N IENS,IENSA,FIELD,FILENUM,TTABLE,TYPE
 ;Clean up DIQOUT remove null entries and change .01's to the resolved
 ;form.
 D CLDIQOUT(.DIQOUT)
 ;Convert the iens to the adding FDA form .
 D BTTABLE(.DIQOUT,.IENROOT,.TTABLE)
 S FILENUM=""
 F  S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM=""  D
 . S IENS=""
 . F  S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS=""  D
 .. S IENSA=TTABLE(FILENUM,IENS)
 .. S FIELD=""
 .. F  S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD=""  D
 ... M DIQOUT(FILENUM,IENSA,FIELD)=DIQOUT(FILENUM,IENS,FIELD)
 .. K DIQOUT(FILENUM,IENS)
 Q
 ;
 ;==================================================
GDIQF(LIST,NUM,TMPIND,SERROR) ;Save file entries into ^TMP(TMPIND,$J).
 N DIQOUT,IENROOT,IND,FIELD,FILENAME,IENS,MSG,PT01,TEMP
 S ^TMP(TMPIND,$J,"NUMF")=NUM
 F IND=1:1:NUM D
 . S TEMP=LIST(IND)
 . S FILENAME=$P(TEMP,U,1)
 . S FILENUM=$P(TEMP,U,2)
 . S IEN=$P(TEMP,U,3)
 . K DIQOUT,IENROOT
 .;If the file entry is ok to install then get the entire entry,
 .;otherwise just get the .01.
 . I $$FOKTI^PXRMEXFI(FILENUM) S FIELD="**"
 . E  S FIELD=.01
 . D GETS^DIQ(FILENUM,IEN,FIELD,"","DIQOUT","MSG")
 . I $D(MSG) D  Q
 .. S SERROR=1,IND=NUM
 .. N ETEXT
 .. S ETEXT="GETS^DIQ failed for "_FILENAME_", ien="_IEN_";"
 .. W !,ETEXT
 .. W !,"it returned the following error:"
 .. D AWRITE^PXRMUTIL("MSG")
 .. H 2
 .. K MSG
 .;Remove edit history from all reminder files.
 . D RMEH(FILENUM,.DIQOUT)
 .;Convert the iens to the FDA adding form.
 . D CONTOFDA(.DIQOUT,.IENROOT)
 .;Load the converted DIQOUT into TMP.
 . M ^TMP(TMPIND,$J,IND,FILENAME)=DIQOUT
 . M ^TMP(TMPIND,$J,IND,FILENAME_"_IENROOT")=IENROOT
 Q
 ;
 ;==================================================
GETREM(ACTION) ;Get the reminder to save.
 N DIC,DUOUT,X,Y
 S DIC="^PXD(811.9,"
 S DIC(0)="AEMQ"
 S DIC("A")="Select Reminder Definition to "_ACTION_": "
 D ^DIC
 Q Y
 ;
 ;==================================================
GRTN(LIST,NUM,TMPIND,SERROR) ;Save routines into ^TMP(TMPIND,$J).
 N DIF,IEN,IND,TEMP,X,XCNP
 S ^TMP(TMPIND,$J,"NUMR")=NUM
 S X=""
 F IND=1:1:NUM D
 .;Make sure the routine exists.
 . S X=LIST(IND)
 . X ^%ZOSF("TEST")
 . I $T D
 .. S DIF="^TMP(TMPIND,$J,""ROUTINE"","""_X_""","
 .. S XCNP=0
 .. X ^%ZOSF("LOAD")
 . E  D
 .. S SERROR=1
 .. W !,"Warning could not find routine ",X
 .. H 2
 Q
 ;
 ;==================================================
RMEH(FILENUM,DIQOUT) ;Clear the edit history from all reminder files.
 ;Leave a stub so it can be filled in when the file is installed.
 I (FILENUM<800)!(FILENUM>811.9) Q
 N IEN,SFN,TARGET
 ;Edit History is stored in node 110 for all files, get the
 ;subfile number.
 D FIELD^DID(FILENUM,110,"","SPECIFIER","TARGET")
 S SFN=+$G(TARGET("SPECIFIER"))
 I SFN=0 Q
 ;Clean out the history.
 S IENS=""
 F  S IENS=$O(DIQOUT(SFN,IENS)) Q:IENS=""  K DIQOUT(SFN,IENS)
 ;Create a stub for the install.
 S IENS="1,"_$O(DIQOUT(FILENUM,""))
 S DIQOUT(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
 S DIQOUT(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
 S DIQOUT(SFN,IENS,2)="DIQOUT("_SFN_","_IENS_"2)"
 S DIQOUT(SFN,IENS,2,1)="Exchange Stub"
 Q
 ;
 ;==================================================
UPDATE(SUCCESS,FDA,FDAIEN) ;Call to add new entries to the repository.
 N MSG
 ;Try to eliminate gaps in the repository.
 S $P(^PXD(811.8,0),U,3)=0
 D UPDATE^DIE("E","FDA","FDAIEN","MSG")
 I $D(MSG) D
 . N DATE,RNAME
 . S SUCCESS=0
 . W !,"The update failed, UPDATE^DIE returned the following error message:"
 . D AWRITE^PXRMUTIL("MSG")
 . S RNAME=FDA(811.8,"+1,",.01)
 . S DATE=FDA(811.8,"+1,",.03)
 . W !!,"Exchange File entry ",RNAME," date packed ",DATE," did not get stored!"
 . W !,"Examine the above error message for the reason.",!
 . H 2
 E  S SUCCESS=1
 Q
 ;