- PXRMEXPU ;SLC/PKR - Utilities for packing and unpacking repository entries. ;12/07/2011
- ;;2.0;CLINICAL REMINDERS;**6,12,22**;Feb 04, 2005;Build 160
- ;==================================================
- 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 IENS,INTERNAL,FIELD,FILENUM,LINE
- N PLEN,PREFIX,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:"")
- ... ;Check if this pointer is ok to transport.
- ... I '$$PTROK(PTRTO) K DIQOUT(FILENUM,IENS,FIELD) Q
- ...;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 PREFIX=$P(VPTRLIST(FILENUM,FIELD,ROOT),U,4)_"."
- .... S PLEN=$L(PREFIX)
- .... I $E(DIQOUT(FILENUM,IENS,FIELD),1,PLEN)'=PREFIX S DIQOUT(FILENUM,IENS,FIELD)=PREFIX_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
- ;
- ;==================================================
- PTROK(PTR) ;Return true if items associated with this pointer are
- ;ok to transport. Note the form of the pointer is that returned
- ;by GET1^DID(FILENUM,FIELD,"","POINTER").
- I PTR="USR(8930," Q 0
- I PTR="VA(200," Q 0
- Q 1
- ;
- ;==================================================
- RMEH(FILENUM,DIQOUT,NOSTUB) ;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 IENS,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.
- I $G(NOSTUB) Q
- 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
- ;
- PXRMEXPU ;SLC/PKR - Utilities for packing and unpacking repository entries. ;12/07/2011
- +1 ;;2.0;CLINICAL REMINDERS;**6,12,22**;Feb 04, 2005;Build 160
- +2 ;==================================================
- BTTABLE(DIQOUT,IENROOT,TTABLE) ;Build the DIQOUT to FDA iens translation table.
- +1 NEW FILENUM,IENS,IENT,IND,UP
- +2 SET FILENUM=$ORDER(DIQOUT(""))
- +3 IF FILENUM=""
- QUIT
- +4 ;DBIA #2631
- +5 SET UP=$GET(^DD(FILENUM,0,"UP"))
- +6 ;Top level file in DIQOUT should not have an up node.
- +7 IF UP=""
- Begin DoDot:1
- +8 SET IENS=$ORDER(DIQOUT(FILENUM,""))
- SET IND=+IENS
- +9 SET TTABLE(FILENUM,IENS)="+"_IENS
- End DoDot:1
- +10 IF '$TEST
- Begin DoDot:1
- +11 WRITE !,"BTTABLE^PXRMEXPU - DIQOUT problem, do not have correct top level"
- End DoDot:1
- QUIT
- +12 ;
- +13 FOR
- SET FILENUM=$ORDER(DIQOUT(FILENUM))
- IF FILENUM=""
- QUIT
- Begin DoDot:1
- +14 SET UP=$GET(^DD(FILENUM,0,"UP"))
- +15 SET IENS=""
- +16 FOR
- SET IENS=$ORDER(DIQOUT(FILENUM,IENS))
- IF IENS=""
- QUIT
- Begin DoDot:2
- +17 SET IND=IND+1
- +18 SET IENT=$PIECE(IENS,",",2,99)
- +19 SET TTABLE(FILENUM,IENS)="+"_IND_","_TTABLE(UP,IENT)
- +20 SET IENROOT(IND)=$PIECE(IENS,",",1)
- End DoDot:2
- End DoDot:1
- +21 QUIT
- +22 ;
- +23 ;==================================================
- CLDIQOUT(DIQOUT) ;Clean up DIQOUT remove null entries and change .01's
- +1 ;to the resolved form.
- +2 NEW IENS,INTERNAL,FIELD,FILENUM,LINE
- +3 NEW PLEN,PREFIX,PTRTO,ROOT,TYPE,WPLCNT,VLIST,VPTRLIST
- +4 SET FILENUM=""
- +5 FOR
- SET FILENUM=$ORDER(DIQOUT(FILENUM))
- IF FILENUM=""
- QUIT
- Begin DoDot:1
- +6 KILL TYPE,VPTRLIST
- +7 SET IENS=""
- +8 FOR
- SET IENS=$ORDER(DIQOUT(FILENUM,IENS))
- IF IENS=""
- QUIT
- Begin DoDot:2
- +9 SET FIELD=""
- +10 FOR
- SET FIELD=$ORDER(DIQOUT(FILENUM,IENS,FIELD))
- IF FIELD=""
- QUIT
- Begin DoDot:3
- +11 ;If there is no data then don't keep this entry.
- +12 IF DIQOUT(FILENUM,IENS,FIELD)=""
- KILL DIQOUT(FILENUM,IENS,FIELD)
- QUIT
- +13 ;Get the field type, if it is a variable-pointer then set up
- +14 ;the resolved form.
- +15 IF '$DATA(TYPE(FILENUM,FIELD))
- SET TYPE(FILENUM,FIELD)=$$GET1^DID(FILENUM,FIELD,"","TYPE")
- +16 SET PTRTO=$SELECT(TYPE(FILENUM,FIELD)="POINTER":$$GET1^DID(FILENUM,FIELD,"","POINTER"),1:"")
- +17 ;Check if this pointer is ok to transport.
- +18 IF '$$PTROK(PTRTO)
- KILL DIQOUT(FILENUM,IENS,FIELD)
- QUIT
- +19 ;If the field's type is COMPUTED then don't transport it.
- +20 IF TYPE(FILENUM,FIELD)="COMPUTED"
- KILL DIQOUT(FILENUM,IENS,FIELD)
- QUIT
- +21 IF TYPE(FILENUM,FIELD)="VARIABLE-POINTER"
- Begin DoDot:4
- +22 IF '$DATA(VPTRLIST(FILENUM,FIELD))
- Begin DoDot:5
- +23 KILL VLIST
- +24 DO BLDRLIST^PXRMVPTR(FILENUM,FIELD,.VLIST)
- +25 MERGE VPTRLIST(FILENUM,FIELD)=VLIST
- End DoDot:5
- +26 SET INTERNAL=$$GET1^DIQ(FILENUM,IENS,FIELD,"I")
- +27 SET (PTRTO,ROOT)=$PIECE(INTERNAL,";",2)
- +28 SET PREFIX=$PIECE(VPTRLIST(FILENUM,FIELD,ROOT),U,4)_"."
- +29 SET PLEN=$LENGTH(PREFIX)
- +30 IF $EXTRACT(DIQOUT(FILENUM,IENS,FIELD),1,PLEN)'=PREFIX
- SET DIQOUT(FILENUM,IENS,FIELD)=PREFIX_DIQOUT(FILENUM,IENS,FIELD)
- End DoDot:4
- +31 IF TYPE(FILENUM,FIELD)="WORD-PROCESSING"
- Begin DoDot:4
- +32 SET (LINE,WPLCNT)=0
- +33 FOR
- SET LINE=$ORDER(DIQOUT(FILENUM,IENS,FIELD,LINE))
- IF LINE=""
- QUIT
- Begin DoDot:5
- +34 SET WPLCNT=WPLCNT+1
- End DoDot:5
- +35 IF WPLCNT>0
- SET DIQOUT(FILENUM,IENS,FIELD)="WP-start~"_WPLCNT
- +36 IF '$TEST
- KILL DIQOUT(FILENUM,IENS,FIELD)
- End DoDot:4
- +37 ;For fields that point to files 80 and 80.1 we have to append a space
- +38 ;so FileMan can resolve the pointers when installing a component.
- +39 IF PTRTO["ICD"
- SET DIQOUT(FILENUM,IENS,FIELD)=DIQOUT(FILENUM,IENS,FIELD)_" "
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +40 QUIT
- +41 ;
- +42 ;==================================================
- CONTOFDA(DIQOUT,IENROOT) ;Convert the iens from the form
- +1 ;returned by GETS^DIQ to the FDA laygo form used by UPDATE^DIE.
- +2 ;DIQOUT contains the GETS^DIQ output. If any of the fields are
- +3 ;variable pointers change them to the resolved form.
- +4 NEW IENS,IENSA,FIELD,FILENUM,TTABLE,TYPE
- +5 ;Clean up DIQOUT remove null entries and change .01's to the resolved
- +6 ;form.
- +7 DO CLDIQOUT(.DIQOUT)
- +8 ;Convert the iens to the adding FDA form.
- +9 DO BTTABLE(.DIQOUT,.IENROOT,.TTABLE)
- +10 SET FILENUM=""
- +11 FOR
- SET FILENUM=$ORDER(DIQOUT(FILENUM))
- IF FILENUM=""
- QUIT
- Begin DoDot:1
- +12 SET IENS=""
- +13 FOR
- SET IENS=$ORDER(DIQOUT(FILENUM,IENS))
- IF IENS=""
- QUIT
- Begin DoDot:2
- +14 SET IENSA=TTABLE(FILENUM,IENS)
- +15 SET FIELD=""
- +16 FOR
- SET FIELD=$ORDER(DIQOUT(FILENUM,IENS,FIELD))
- IF FIELD=""
- QUIT
- Begin DoDot:3
- +17 MERGE DIQOUT(FILENUM,IENSA,FIELD)=DIQOUT(FILENUM,IENS,FIELD)
- End DoDot:3
- +18 KILL DIQOUT(FILENUM,IENS)
- End DoDot:2
- End DoDot:1
- +19 QUIT
- +20 ;
- +21 ;==================================================
- PTROK(PTR) ;Return true if items associated with this pointer are
- +1 ;ok to transport. Note the form of the pointer is that returned
- +2 ;by GET1^DID(FILENUM,FIELD,"","POINTER").
- +3 IF PTR="USR(8930,"
- QUIT 0
- +4 IF PTR="VA(200,"
- QUIT 0
- +5 QUIT 1
- +6 ;
- +7 ;==================================================
- RMEH(FILENUM,DIQOUT,NOSTUB) ;Clear the edit history from all reminder files.
- +1 ;Leave a stub so it can be filled in when the file is installed.
- +2 IF (FILENUM<800)!(FILENUM>811.9)
- QUIT
- +3 NEW IENS,SFN,TARGET
- +4 ;Edit History is stored in node 110 for all files, get the
- +5 ;subfile number.
- +6 DO FIELD^DID(FILENUM,110,"","SPECIFIER","TARGET")
- +7 SET SFN=+$GET(TARGET("SPECIFIER"))
- +8 IF SFN=0
- QUIT
- +9 ;Clean out the history.
- +10 SET IENS=""
- +11 FOR
- SET IENS=$ORDER(DIQOUT(SFN,IENS))
- IF IENS=""
- QUIT
- KILL DIQOUT(SFN,IENS)
- +12 ;Create a stub for the install.
- +13 IF $GET(NOSTUB)
- QUIT
- +14 SET IENS="1,"_$ORDER(DIQOUT(FILENUM,""))
- +15 SET DIQOUT(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
- +16 SET DIQOUT(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
- +17 SET DIQOUT(SFN,IENS,2)="DIQOUT("_SFN_","_IENS_"2)"
- +18 SET DIQOUT(SFN,IENS,2,1)="Exchange Stub"
- +19 QUIT
- +20 ;
- +21 ;==================================================
- UPDATE(SUCCESS,FDA,FDAIEN) ;Call to add new entries to the repository.
- +1 NEW MSG
- +2 ;Try to eliminate gaps in the repository.
- +3 SET $PIECE(^PXD(811.8,0),U,3)=0
- +4 DO UPDATE^DIE("E","FDA","FDAIEN","MSG")
- +5 IF $DATA(MSG)
- Begin DoDot:1
- +6 NEW DATE,RNAME
- +7 SET SUCCESS=0
- +8 WRITE !,"The update failed, UPDATE^DIE returned the following error message:"
- +9 DO AWRITE^PXRMUTIL("MSG")
- +10 SET RNAME=FDA(811.8,"+1,",.01)
- +11 SET DATE=FDA(811.8,"+1,",.03)
- +12 WRITE !!,"Exchange File entry ",RNAME," date packed ",DATE," did not get stored!"
- +13 WRITE !,"Examine the above error message for the reason.",!
- +14 HANG 2
- End DoDot:1
- +15 IF '$TEST
- SET SUCCESS=1
- +16 QUIT
- +17 ;
