PXRMEXPU ;SLC/PKR - Utilities for packing and unpacking repository entries. ;10/24/2018
;;2.0;CLINICAL REMINDERS;**6,12,22,45**;Feb 04, 2005;Build 566
;==================================================
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
;
DIALOGGF(FILENUM,IEN,ARRAY) ;
N ERROR,IENS,NAME,OUTPUT,PKGIEN,PREFIX,VALUE
S IENS="+"_IEN_","
S VALUE=$G(ARRAY(FILENUM,IENS,2)) I VALUE="" Q
S PKGIEN=$P($G(^PXRMD(801.46,IEN,0)),U,2) I PKGIEN'>0 Q
D GETS^DIQ(9.4,PKGIEN_",",".01;1","I","OUTPUT","ERROR")
S NAME=$G(OUTPUT(9.4,PKGIEN_",",.01,"I")) I NAME="" Q
S PREFIX=$G(OUTPUT(9.4,PKGIEN_",",1,"I")) I PREFIX="" Q
S ARRAY(FILENUM,IENS,2)=NAME_U_PREFIX
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
;
;==========================
TIUCONV(FILENUM,IEN,ARRAY) ;Convert health summary object to external.
N HSO,IENS,NAME
S IENS="+"_IEN_","
;Allows non-objects to be packed up
I ARRAY(FILENUM,IENS,.04)'="OBJECT" Q
;
I $G(ARRAY(FILENUM,IENS,9))'["$$TIU^GMTSOBJ" D Q
. S ARRAY(FILENUM,IENS,9)="NOT A HS OBJECT"
S HSO=$P(ARRAY(FILENUM,IENS,9),",",2)
S HSO=$P(HSO,")")
;Handle corrupted health summary object names.
I +HSO>0 S NAME=$P($G(^GMT(142.5,HSO,0)),U,1)
E S NAME="MISSING"
S ARRAY(FILENUM,IENS,9)="S X=$$TIU^GMTSOBJ(DFN,"_NAME_")"
S ARRAY(FILENUM,IENS,99)=""
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEXPU 6679 printed Apr 09, 2024@20:54:46 Page 2
PXRMEXPU ;SLC/PKR - Utilities for packing and unpacking repository entries. ;10/24/2018
+1 ;;2.0;CLINICAL REMINDERS;**6,12,22,45**;Feb 04, 2005;Build 566
+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 ;
DIALOGGF(FILENUM,IEN,ARRAY) ;
+1 NEW ERROR,IENS,NAME,OUTPUT,PKGIEN,PREFIX,VALUE
+2 SET IENS="+"_IEN_","
+3 SET VALUE=$GET(ARRAY(FILENUM,IENS,2))
IF VALUE=""
QUIT
+4 SET PKGIEN=$PIECE($GET(^PXRMD(801.46,IEN,0)),U,2)
IF PKGIEN'>0
QUIT
+5 DO GETS^DIQ(9.4,PKGIEN_",",".01;1","I","OUTPUT","ERROR")
+6 SET NAME=$GET(OUTPUT(9.4,PKGIEN_",",.01,"I"))
IF NAME=""
QUIT
+7 SET PREFIX=$GET(OUTPUT(9.4,PKGIEN_",",1,"I"))
IF PREFIX=""
QUIT
+8 SET ARRAY(FILENUM,IENS,2)=NAME_U_PREFIX
+9 QUIT
+10 ;
+11 ;==================================================
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 ;==========================
TIUCONV(FILENUM,IEN,ARRAY) ;Convert health summary object to external.
+1 NEW HSO,IENS,NAME
+2 SET IENS="+"_IEN_","
+3 ;Allows non-objects to be packed up
+4 IF ARRAY(FILENUM,IENS,.04)'="OBJECT"
QUIT
+5 ;
+6 IF $GET(ARRAY(FILENUM,IENS,9))'["$$TIU^GMTSOBJ"
Begin DoDot:1
+7 SET ARRAY(FILENUM,IENS,9)="NOT A HS OBJECT"
End DoDot:1
QUIT
+8 SET HSO=$PIECE(ARRAY(FILENUM,IENS,9),",",2)
+9 SET HSO=$PIECE(HSO,")")
+10 ;Handle corrupted health summary object names.
+11 IF +HSO>0
SET NAME=$PIECE($GET(^GMT(142.5,HSO,0)),U,1)
+12 IF '$TEST
SET NAME="MISSING"
+13 SET ARRAY(FILENUM,IENS,9)="S X=$$TIU^GMTSOBJ(DFN,"_NAME_")"
+14 SET ARRAY(FILENUM,IENS,99)=""
+15 QUIT
+16 ;
+17 ;==================================================
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 ;
