INHUTC11 ;bar; 19 Jun 97 17:29; Internal Functions for Criteria Mgmt
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;;COPYRIGHT 1997 SAIC
Q
;
SAVE(INOPT,INDA,INCTRL) ; save working record to user defined record
;
; input: INOPT array. See INHUTCD for description.
; INDA = entry in criteria file (req)
; INCTRL = S, U, B, or W. control value of saved record (opt)
; returns: ien of record in INTERFACE CRITERIA file
; if function does not complete, reason text is returned.
;
Q:'$G(INDA) "SAVE: Entry number not supplied"
S INCTRL=$S('$L($G(INCTRL)):"U","SUBW"[INCTRL:INCTRL,1:"U")
N INX,INAME,INOK,INOPT2
; get save field value
S INX=$G(^DIZ(4001.1,INDA,0)),INAME=$P(INX,U,4)
; quit if not to be saved
Q:'$L(INAME) INDA
; see if name exists already
S INOPT2("DUZ")=$P(INX,U,2),INOPT2("TYPE")=$P(INX,U,5),INOPT2("APP")=$P(INX,U,8),INOPT2("FUNC")=$P(INX,U,6),INOPT2("CONTROL")=INCTRL
S INFROM=$$LOOKUP^INHUTC1(.INOPT2,INAME)
; interactive mode, name exists, does not match selected name,
; ask to overwrite
S INOK=1 I '$G(INOPT("NONINTER")),INFROM,INAME'=$P($G(INOPT("SELECTED")),U,2) S INOK=$$YN^UTWRD("Overwrite "_INAME_" with new version? ;0")
; return answer
S INOPT("OVERWRITE")=INOK
; and if they say no? remove name and quit
I 'INOK D Q INDA
. N DIC,DIE,DA S DIE=4001.1,DR=".04///@",DA=INDA D ^DIE
; if entry does not already exist, create new entry
S:'INFROM INFROM=$$NEW^INHUTC1(.INOPT,INCTRL)
; copy data to record
D COPY(INDA,INFROM,INCTRL)
Q INDA
;
COPY(INFROM,INTO,INCTRL) ; copy search fields from one entry to another
; input: INFROM = ien to INTERFACE CRITERIA file to copy from. (opt)
; if 0, will clear contents of INTO
; INTO = ien to INTERFACE CRITERIA file to copy to (req)
; INCTRL = CONTROL field value of "TO" entry (opt)
;
Q:'$G(INTO) S INFROM=$G(INFROM,0),INCTRL=$G(INCTRL)
N DIK,DA
; delete current x-refs
S DIK="^DIZ(4001.1,",DA=INTO
; VA/IHS FileMan does not have IX2 tag
I $$SC^INHUTIL1 D IX2^DIK
; clear current fields, clear name if no from entry
S DA=0 F S DA=$O(^DIZ(4001.1,INTO,DA)) Q:'DA K ^(DA)
S $P(^DIZ(4001.1,INTO,0),U,4)=""
; move entry
M:INFROM ^DIZ(4001.1,INTO)=^DIZ(4001.1,INFROM)
; update .01 field
S $P(^DIZ(4001.1,INTO,0),U,1)=INTO
; update CONTROL field
I $L($G(INCTRL)) S $P(^DIZ(4001.1,INTO,0),U,3)=INCTRL
; update INTO entry with last access date
S $P(^DIZ(4001.1,INTO,0),U,9)=$$DT^%ZTFDT
; if copied from system record, blank name
I INFROM,$P(^DIZ(4001.1,INFROM,0),U,3)="S" S $P(^DIZ(4001.1,INTO,0),U,4)=""
; reindex this entry
S DIK="^DIZ(4001.1,",DA=INTO D IX1^DIK
Q
;
EDIT(INDA,INGALL) ; edit criteria entry
;
; input: INDA = ien of criteria file entry (req)
; INGALL = gallery name (req)
; returns: ien of criteria entry if no errors
; on error, returns text of error
;
Q:'$G(INDA) "EDIT: Interface Criteria entry not supplied."
; Force ^DWC to ask to file then Preset the fields for another search
; removed DWASK="" to not force it bar 02/05/97
; For IHS, don't deal with DWC.
I $$SC^INHUTIL1 S DA=INDA,DWN=INGALL,DIE=4001.1,DWASK="" D ^DWC
Q:$D(DTOUT)!$D(DUOUT) "EDIT: User aborted gallery edit."
; update edited date
S $P(^DIZ(4001.1,INDA,0),U,9)=$$DT^%ZTFDT
Q INDA
;
INHUTC11 ;bar; 19 Jun 97 17:29; Internal Functions for Criteria Mgmt
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;;COPYRIGHT 1997 SAIC
+4 QUIT
+5 ;
SAVE(INOPT,INDA,INCTRL) ; save working record to user defined record
+1 ;
+2 ; input: INOPT array. See INHUTCD for description.
+3 ; INDA = entry in criteria file (req)
+4 ; INCTRL = S, U, B, or W. control value of saved record (opt)
+5 ; returns: ien of record in INTERFACE CRITERIA file
+6 ; if function does not complete, reason text is returned.
+7 ;
+8 IF '$GET(INDA)
QUIT "SAVE: Entry number not supplied"
+9 SET INCTRL=$SELECT('$LENGTH($GET(INCTRL)):"U","SUBW"[INCTRL:INCTRL,1:"U")
+10 NEW INX,INAME,INOK,INOPT2
+11 ; get save field value
+12 SET INX=$GET(^DIZ(4001.1,INDA,0))
SET INAME=$PIECE(INX,U,4)
+13 ; quit if not to be saved
+14 IF '$LENGTH(INAME)
QUIT INDA
+15 ; see if name exists already
+16 SET INOPT2("DUZ")=$PIECE(INX,U,2)
SET INOPT2("TYPE")=$PIECE(INX,U,5)
SET INOPT2("APP")=$PIECE(INX,U,8)
SET INOPT2("FUNC")=$PIECE(INX,U,6)
SET INOPT2("CONTROL")=INCTRL
+17 SET INFROM=$$LOOKUP^INHUTC1(.INOPT2,INAME)
+18 ; interactive mode, name exists, does not match selected name,
+19 ; ask to overwrite
+20 SET INOK=1
IF '$GET(INOPT("NONINTER"))
IF INFROM
IF INAME'=$PIECE($GET(INOPT("SELECTED")),U,2)
SET INOK=$$YN^UTWRD("Overwrite "_INAME_" with new version? ;0")
+21 ; return answer
+22 SET INOPT("OVERWRITE")=INOK
+23 ; and if they say no? remove name and quit
+24 IF 'INOK
Begin DoDot:1
+25 NEW DIC,DIE,DA
SET DIE=4001.1
SET DR=".04///@"
SET DA=INDA
DO ^DIE
End DoDot:1
QUIT INDA
+26 ; if entry does not already exist, create new entry
+27 IF 'INFROM
SET INFROM=$$NEW^INHUTC1(.INOPT,INCTRL)
+28 ; copy data to record
+29 DO COPY(INDA,INFROM,INCTRL)
+30 QUIT INDA
+31 ;
COPY(INFROM,INTO,INCTRL) ; copy search fields from one entry to another
+1 ; input: INFROM = ien to INTERFACE CRITERIA file to copy from. (opt)
+2 ; if 0, will clear contents of INTO
+3 ; INTO = ien to INTERFACE CRITERIA file to copy to (req)
+4 ; INCTRL = CONTROL field value of "TO" entry (opt)
+5 ;
+6 IF '$GET(INTO)
QUIT
SET INFROM=$GET(INFROM,0)
SET INCTRL=$GET(INCTRL)
+7 NEW DIK,DA
+8 ; delete current x-refs
+9 SET DIK="^DIZ(4001.1,"
SET DA=INTO
+10 ; VA/IHS FileMan does not have IX2 tag
+11 IF $$SC^INHUTIL1
DO IX2^DIK
+12 ; clear current fields, clear name if no from entry
+13 SET DA=0
FOR
SET DA=$ORDER(^DIZ(4001.1,INTO,DA))
IF 'DA
QUIT
KILL ^(DA)
+14 SET $PIECE(^DIZ(4001.1,INTO,0),U,4)=""
+15 ; move entry
+16 IF INFROM
MERGE ^DIZ(4001.1,INTO)=^DIZ(4001.1,INFROM)
+17 ; update .01 field
+18 SET $PIECE(^DIZ(4001.1,INTO,0),U,1)=INTO
+19 ; update CONTROL field
+20 IF $LENGTH($GET(INCTRL))
SET $PIECE(^DIZ(4001.1,INTO,0),U,3)=INCTRL
+21 ; update INTO entry with last access date
+22 SET $PIECE(^DIZ(4001.1,INTO,0),U,9)=$$DT^%ZTFDT
+23 ; if copied from system record, blank name
+24 IF INFROM
IF $PIECE(^DIZ(4001.1,INFROM,0),U,3)="S"
SET $PIECE(^DIZ(4001.1,INTO,0),U,4)=""
+25 ; reindex this entry
+26 SET DIK="^DIZ(4001.1,"
SET DA=INTO
DO IX1^DIK
+27 QUIT
+28 ;
EDIT(INDA,INGALL) ; edit criteria entry
+1 ;
+2 ; input: INDA = ien of criteria file entry (req)
+3 ; INGALL = gallery name (req)
+4 ; returns: ien of criteria entry if no errors
+5 ; on error, returns text of error
+6 ;
+7 IF '$GET(INDA)
QUIT "EDIT: Interface Criteria entry not supplied."
+8 ; Force ^DWC to ask to file then Preset the fields for another search
+9 ; removed DWASK="" to not force it bar 02/05/97
+10 ; For IHS, don't deal with DWC.
+11 IF $$SC^INHUTIL1
SET DA=INDA
SET DWN=INGALL
SET DIE=4001.1
SET DWASK=""
DO ^DWC
+12 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT "EDIT: User aborted gallery edit."
+13 ; update edited date
+14 SET $PIECE(^DIZ(4001.1,INDA,0),U,9)=$$DT^%ZTFDT
+15 QUIT INDA
+16 ;
