INHUTC1 ;bar; 22 Jul 97 15:37; Internal Functions for Criteria Mgmt
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;;COPYRIGHT 1997 SAIC
Q
;
GET(INOPT) ; return a working entry in the INTERFACE CRITERIA file
; selection and edit are called if appropriate
;
; input: INOPT array. See top of INHUTC for description.
; returns: ien of record in INTERFACE CRITERIA file
; if function does not complete, reason text is returned
;
N X,Y,INDA,INX,INAME,INFROM
; validate name or ien passed in. if name is ien convert to name
S INFROM=0,INAME=$G(INOPT("NAME"))
I INAME=+INAME S INFROM=INAME,INAME=$P($G(^DIZ(4001.1,INFROM,0)),U,4)
E I $L(INAME),'INFROM S INFROM=$$LOOKUP(.INOPT,INAME,0)
I INFROM,'$$VALID(.INOPT,INFROM,"WUS") Q "GET: NAME value: "_INOPT("NAME")_" is not a valid INTERFACE CRITERIA type."
; user lookup here
I '$G(INOPT("NONINTER")) S X="" D S INFROM=$S(X<1:0,1:X) I X["^" Q "GET: User abort from select"
. N INB
. I $D(INOPT("PROMPT")) S INB=INOPT("PROMPT")
. E D
.. S INB=$G(INOPT("TYPE")),INB="Select Interface "_$E(INB)_$$DNCASE^%ZTF($E(INB,2,$L(INB)))_" criteria name: "
.. S INB=INB_";;;;"_$G(INAME)_";;;;S X=$$LOOKUP^INHUTC1(.INOPT,X,1) K:'X X"
.;If system is IHS, call ScreenMan
.I '$$SC^INHUTIL1 D Q
..S X=$$NEW(.INOPT,"W")
..S DA=X
..N DDSFILE,DR,DDSPAGE,DDSPARM,DDSAVE
..S DDSFILE="^DIZ(4001.1,",DR="["_INOPT("GALLERY")_"]",DDSPAGE=1,DDSPARM="S"
..D ^DDS
..I '$G(DDSSAVE) S X="^"
..;END IHS BRANCH
. D CLEAR^DW F D Q:X!(X["^")
.. D ^UTWRD(INB,1) Q:X!(X["^")
.. I '$L(X) S X=$$NEW(.INOPT,"W") Q
.. I X="?" D GETHELP(.X) Q:'$L(X)!(X["^")
.. S X=$$LOOKUP^INHUTC1(.INOPT,X,1) Q:X!(X["^") Q:$D(DTOUT)!$D(DUOUT)
. D CLEAR^DW
; save selected entry name
S:INFROM INOPT("SELECTED")=INFROM_U_$P($G(^DIZ(4001.1,INFROM,0)),U,4)
; if the entry is a working rec, just use it
I INFROM,$P($G(^DIZ(4001.1,INFROM,0)),U,3)="W" Q INFROM
; get a work entry and populate with found entry
S INDA=$$WORKREC(.INOPT,$G(INOPT("NEW"),0)) D COPY(INFROM,INDA,"W")
Q INDA
;
GETHELP(INX) ; help for criteria lookup screen
D MESS^DWD(14,2)
W !,"Interface Criteria:"
W !," Enter '??' for a list of saved criteria entries."
W !," Enter '^' or the press the <ABORT> key to exit"
W !," Enter a name or partial name to look up a saved criteria."
W !," <SPACE> and <RETURN> will recall the last criteria used."
W !," <RETURN> or <ENTER> alone will create a new criteria entry."
W !!," A criteria entry does not need to be 'named'. If not named,"
W !," it is a working entry and is temporary. The last working"
W !," entry can be recalled with the <SPACE>."
S %=$$CR^UTSRD,INX=$S(%:"^",1:"??") D CLPOP^DWD
Q
;
LOOKUP(INOPT,X,INUS) ; lookup entry in INTERFACE CRITERIA file
;
; input: INOPT array. See INHUTCD for description.
; X = value to look up
; INUS = if TRUE (1) will call full screen selection
;
; returns: ien of record in INTERFACE CRITERIA file
; if function does not complete, reason text is returned
;
; quit if user information does not exist, validate input variables
N D,Y,DIC K DUOUT,DTOUT
; check for spacebar
S X=$G(X) Q:X=" " $$WORKREC(.INOPT,0)
S DIC=4001.1,D="C",DIC(0)="FNXY",DIC("S")=$$FILTER(.INOPT)
S:$G(INUS) DIC(0)="EFNR"
D IX^DIC Q:$D(DTOUT)!$D(DUOUT) "LOOKUP: User exit"
; if multiple entries pick last one
I Y=0 S Y=+$O(Y(" "),-1)
Q $S(Y<1:0,1:+Y)
;
FILTER(INOPT) ; create filter screen for lookup in INTERFACE CRITERIA file
;
; input: INOPT array. See INHUTCD for description.
; returns: executable text for use with DIC("S") for lookup
; ie; S %=^(0) I ($P(%,U,3)="U"&($P(%,U,2)=185))
;
N INI,INP,INCTRL,INFLD,INSTR
S INCTRL=$S($L($G(INOPT("CONTROL"))):INOPT("CONTROL"),1:"SU")
; build based on control values
S INSTR="" S:INCTRL["U" INSTR="($P(%,U,3)=""U""&($P(%,U,2)="_$G(INOPT("DUZ"))_"))"
S INCTRL=$TR(INCTRL,"U")
F INI=1:1 S INP=$E(INCTRL,INI) Q:'$L(INP) S INSTR=INSTR_$S($L(INSTR):"!",1:"")_"($P(%,U,3)="""_INP_""")"
; build based on TYPE values
F INI=1:1:3 D
. S INP=$P("5,8,6",",",INI),INFLD=$G(INOPT($P("TYPE,APP,FUNC",",",INI)))
. S:$L(INFLD) INSTR=INSTR_",$P(%,U,"_INP_")="""_INFLD_""""
Q "S %=^(0) I "_INSTR
;
VALID(INOPT,INDA,INCTRL) ; validate an entry matches options passed
;
; input: INOPT array. See INHUTCD for description.
; INDA = entry in INTERFACE CRITERIA file
; INCTRL = Allowable control values. ie; "SU"
; returns: Boolean. TRUE = valid, FALSE = invalid
;
Q:'$G(INDA) 0
Q:'$D(^DIZ(4001.1,INDA,0)) 0
N INX S INX=^DIZ(4001.1,INDA,0)
Q:$P(INX,U,2)'=$G(INOPT("DUZ")) 0
Q:$P(INX,U,5)'=$G(INOPT("TYPE")) 0
Q:$G(INCTRL)'[$P(INX,U,3) 0
Q:$P(INX,U,8)'=$G(INOPT("APP")) 0
Q:$P(INX,U,6)'=$G(INOPT("FUNC")) 0
Q 1
;
WORKREC(INOPT,INEW) ; lookup last working record, create new if none
;
; input: INOPT array. See INHUTCD for description.
; INEW = force a new record
; returns: ien of record in INTERFACE CRITERIA file
; if function does not complete, reason text is returned
;
N INDA S INDA=0
I '$G(INEW) D
. N I,INA
. F I=1:1:4 S INA(I)=$G(INOPT($P("DUZ,TYPE,APP,FUNC",",",I))) S:'$L(INA(I)) INA(I)="NULL"
. S Y=" " F D Q:INDA!('$L(Y))
.. S Y=$O(^DIZ(4001.1,"AUSER",INA(1),INA(2),"W",INA(3),INA(4),Y),-1)
.. I Y,$$LOCK^INHUTC(Y,1,5) S INOPT("LOCK",Y)=$G(INOPT("LOCK",Y))+1,INDA=Y
; if no working record or its locked, create a new one
I 'INDA S INDA=$$NEW(.INOPT,"W") Q:'INDA INDA
Q $S(INDA<1:"WORKREC: Cannot create entry in INTERFACE CRITERIA file.",1:INDA)
;
NEW(INOPT,INCTRL) ; create new entry in INTERFACE CRITERIA file
;
; input: INOPT array. See INHUTCD for description.
; INCTRL = S, U, B, or W. control value of new record
; returns: ien of record in INTERFACE CRITERIA file
; if function does not complete, reason text is returned
;
Q:'$L($G(INCTRL)) "NEW: Control value not supplied"
N DIC,DIE,DLAYGO,DA,DR,X,Y,INDA,INI
S DIC=4001.1,DIC(0)="LF",DLAYGO=4001.1,X="NEW"
F INI=1:1:5 D Q:INDA
. D:$$SC^INHUTIL1 EN^DICN
. ;Branch for IHS
. I '$$SC^INHUTIL1 S DIC="^DIZ(4001.1," D NEW^DICN
. S (DA,INDA)=+Y Q:INDA<0
. ; get lock on entry
. S:'$$LOCK^INHUTC(INDA,1,5) INDA=0 S:INDA INOPT("LOCK",INDA)=$G(INOPT("LOCK",INDA))+1
Q:INDA<0 "NEW: Entry could not be created"
S DIE=DIC,DR=".01///"_DA_";.02///^S X=DUZ;.03///"_INCTRL_";.09///^S X=DT"_$S($L($G(INOPT("TYPE"))):";.05///"_INOPT("TYPE"),1:"")
S DR=DR_$S($L($G(INOPT("FUNC"))):";.06///"_INOPT("FUNC"),1:"")_$S($L($G(INOPT("APP"))):";.08///"_INOPT("APP"),1:"")_";11///0;12///0"
D ^DIE
Q INDA
;
SAVE(INOPT,INDA,INCTRL) ; save working record to user defined record
Q $$SAVE^INHUTC11(.INOPT,$G(INDA),$G(INCTRL))
;
COPY(INFROM,INTO,INCTRL) ; copy search fields from one entry to another
D COPY^INHUTC11($G(INFROM),$G(INTO),$G(INCTRL))
Q
;
EDIT(INDA,INGALL) ; edit criteria entry
Q $$EDIT^INHUTC11($G(INDA),$G(INGALL))
;
INHUTC1 ;bar; 22 Jul 97 15:37; 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 ;
GET(INOPT) ; return a working entry in the INTERFACE CRITERIA file
+1 ; selection and edit are called if appropriate
+2 ;
+3 ; input: INOPT array. See top of INHUTC for description.
+4 ; returns: ien of record in INTERFACE CRITERIA file
+5 ; if function does not complete, reason text is returned
+6 ;
+7 NEW X,Y,INDA,INX,INAME,INFROM
+8 ; validate name or ien passed in. if name is ien convert to name
+9 SET INFROM=0
SET INAME=$GET(INOPT("NAME"))
+10 IF INAME=+INAME
SET INFROM=INAME
SET INAME=$PIECE($GET(^DIZ(4001.1,INFROM,0)),U,4)
+11 IF '$TEST
IF $LENGTH(INAME)
IF 'INFROM
SET INFROM=$$LOOKUP(.INOPT,INAME,0)
+12 IF INFROM
IF '$$VALID(.INOPT,INFROM,"WUS")
QUIT "GET: NAME value: "_INOPT("NAME")_" is not a valid INTERFACE CRITERIA type."
+13 ; user lookup here
+14 IF '$GET(INOPT("NONINTER"))
SET X=""
Begin DoDot:1
+15 NEW INB
+16 IF $DATA(INOPT("PROMPT"))
SET INB=INOPT("PROMPT")
+17 IF '$TEST
Begin DoDot:2
+18 SET INB=$GET(INOPT("TYPE"))
SET INB="Select Interface "_$EXTRACT(INB)_$$DNCASE^%ZTF($EXTRACT(INB,2,$LENGTH(INB)))_" criteria name: "
+19 SET INB=INB_";;;;"_$GET(INAME)_";;;;S X=$$LOOKUP^INHUTC1(.INOPT,X,1) K:'X X"
End DoDot:2
+20 ;If system is IHS, call ScreenMan
+21 IF '$$SC^INHUTIL1
Begin DoDot:2
+22 SET X=$$NEW(.INOPT,"W")
+23 SET DA=X
+24 NEW DDSFILE,DR,DDSPAGE,DDSPARM,DDSAVE
+25 SET DDSFILE="^DIZ(4001.1,"
SET DR="["_INOPT("GALLERY")_"]"
SET DDSPAGE=1
SET DDSPARM="S"
+26 DO ^DDS
+27 IF '$GET(DDSSAVE)
SET X="^"
+28 ;END IHS BRANCH
End DoDot:2
QUIT
+29 DO CLEAR^DW
FOR
Begin DoDot:2
+30 DO ^UTWRD(INB,1)
IF X!(X["^")
QUIT
+31 IF '$LENGTH(X)
SET X=$$NEW(.INOPT,"W")
QUIT
+32 IF X="?"
DO GETHELP(.X)
IF '$LENGTH(X)!(X["^")
QUIT
+33 SET X=$$LOOKUP^INHUTC1(.INOPT,X,1)
IF X!(X["^")
QUIT
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
End DoDot:2
IF X!(X["^")
QUIT
+34 DO CLEAR^DW
End DoDot:1
SET INFROM=$SELECT(X<1:0,1:X)
IF X["^"
QUIT "GET: User abort from select"
+35 ; save selected entry name
+36 IF INFROM
SET INOPT("SELECTED")=INFROM_U_$PIECE($GET(^DIZ(4001.1,INFROM,0)),U,4)
+37 ; if the entry is a working rec, just use it
+38 IF INFROM
IF $PIECE($GET(^DIZ(4001.1,INFROM,0)),U,3)="W"
QUIT INFROM
+39 ; get a work entry and populate with found entry
+40 SET INDA=$$WORKREC(.INOPT,$GET(INOPT("NEW"),0))
DO COPY(INFROM,INDA,"W")
+41 QUIT INDA
+42 ;
GETHELP(INX) ; help for criteria lookup screen
+1 DO MESS^DWD(14,2)
+2 WRITE !,"Interface Criteria:"
+3 WRITE !," Enter '??' for a list of saved criteria entries."
+4 WRITE !," Enter '^' or the press the <ABORT> key to exit"
+5 WRITE !," Enter a name or partial name to look up a saved criteria."
+6 WRITE !," <SPACE> and <RETURN> will recall the last criteria used."
+7 WRITE !," <RETURN> or <ENTER> alone will create a new criteria entry."
+8 WRITE !!," A criteria entry does not need to be 'named'. If not named,"
+9 WRITE !," it is a working entry and is temporary. The last working"
+10 WRITE !," entry can be recalled with the <SPACE>."
+11 SET %=$$CR^UTSRD
SET INX=$SELECT(%:"^",1:"??")
DO CLPOP^DWD
+12 QUIT
+13 ;
LOOKUP(INOPT,X,INUS) ; lookup entry in INTERFACE CRITERIA file
+1 ;
+2 ; input: INOPT array. See INHUTCD for description.
+3 ; X = value to look up
+4 ; INUS = if TRUE (1) will call full screen selection
+5 ;
+6 ; returns: ien of record in INTERFACE CRITERIA file
+7 ; if function does not complete, reason text is returned
+8 ;
+9 ; quit if user information does not exist, validate input variables
+10 NEW D,Y,DIC
KILL DUOUT,DTOUT
+11 ; check for spacebar
+12 SET X=$GET(X)
IF X=" "
QUIT $$WORKREC(.INOPT,0)
+13 SET DIC=4001.1
SET D="C"
SET DIC(0)="FNXY"
SET DIC("S")=$$FILTER(.INOPT)
+14 IF $GET(INUS)
SET DIC(0)="EFNR"
+15 DO IX^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT "LOOKUP: User exit"
+16 ; if multiple entries pick last one
+17 IF Y=0
SET Y=+$ORDER(Y(" "),-1)
+18 QUIT $SELECT(Y<1:0,1:+Y)
+19 ;
FILTER(INOPT) ; create filter screen for lookup in INTERFACE CRITERIA file
+1 ;
+2 ; input: INOPT array. See INHUTCD for description.
+3 ; returns: executable text for use with DIC("S") for lookup
+4 ; ie; S %=^(0) I ($P(%,U,3)="U"&($P(%,U,2)=185))
+5 ;
+6 NEW INI,INP,INCTRL,INFLD,INSTR
+7 SET INCTRL=$SELECT($LENGTH($GET(INOPT("CONTROL"))):INOPT("CONTROL"),1:"SU")
+8 ; build based on control values
+9 SET INSTR=""
IF INCTRL["U"
SET INSTR="($P(%,U,3)=""U""&($P(%,U,2)="_$GET(INOPT("DUZ"))_"))"
+10 SET INCTRL=$TRANSLATE(INCTRL,"U")
+11 FOR INI=1:1
SET INP=$EXTRACT(INCTRL,INI)
IF '$LENGTH(INP)
QUIT
SET INSTR=INSTR_$SELECT($LENGTH(INSTR):"!",1:"")_"($P(%,U,3)="""_INP_""")"
+12 ; build based on TYPE values
+13 FOR INI=1:1:3
Begin DoDot:1
+14 SET INP=$PIECE("5,8,6",",",INI)
SET INFLD=$GET(INOPT($PIECE("TYPE,APP,FUNC",",",INI)))
+15 IF $LENGTH(INFLD)
SET INSTR=INSTR_",$P(%,U,"_INP_")="""_INFLD_""""
End DoDot:1
+16 QUIT "S %=^(0) I "_INSTR
+17 ;
VALID(INOPT,INDA,INCTRL) ; validate an entry matches options passed
+1 ;
+2 ; input: INOPT array. See INHUTCD for description.
+3 ; INDA = entry in INTERFACE CRITERIA file
+4 ; INCTRL = Allowable control values. ie; "SU"
+5 ; returns: Boolean. TRUE = valid, FALSE = invalid
+6 ;
+7 IF '$GET(INDA)
QUIT 0
+8 IF '$DATA(^DIZ(4001.1,INDA,0))
QUIT 0
+9 NEW INX
SET INX=^DIZ(4001.1,INDA,0)
+10 IF $PIECE(INX,U,2)'=$GET(INOPT("DUZ"))
QUIT 0
+11 IF $PIECE(INX,U,5)'=$GET(INOPT("TYPE"))
QUIT 0
+12 IF $GET(INCTRL)'[$PIECE(INX,U,3)
QUIT 0
+13 IF $PIECE(INX,U,8)'=$GET(INOPT("APP"))
QUIT 0
+14 IF $PIECE(INX,U,6)'=$GET(INOPT("FUNC"))
QUIT 0
+15 QUIT 1
+16 ;
WORKREC(INOPT,INEW) ; lookup last working record, create new if none
+1 ;
+2 ; input: INOPT array. See INHUTCD for description.
+3 ; INEW = force a new record
+4 ; returns: ien of record in INTERFACE CRITERIA file
+5 ; if function does not complete, reason text is returned
+6 ;
+7 NEW INDA
SET INDA=0
+8 IF '$GET(INEW)
Begin DoDot:1
+9 NEW I,INA
+10 FOR I=1:1:4
SET INA(I)=$GET(INOPT($PIECE("DUZ,TYPE,APP,FUNC",",",I)))
IF '$LENGTH(INA(I))
SET INA(I)="NULL"
+11 SET Y=" "
FOR
Begin DoDot:2
+12 SET Y=$ORDER(^DIZ(4001.1,"AUSER",INA(1),INA(2),"W",INA(3),INA(4),Y),-1)
+13 IF Y
IF $$LOCK^INHUTC(Y,1,5)
SET INOPT("LOCK",Y)=$GET(INOPT("LOCK",Y))+1
SET INDA=Y
End DoDot:2
IF INDA!('$LENGTH(Y))
QUIT
End DoDot:1
+14 ; if no working record or its locked, create a new one
+15 IF 'INDA
SET INDA=$$NEW(.INOPT,"W")
IF 'INDA
QUIT INDA
+16 QUIT $SELECT(INDA<1:"WORKREC: Cannot create entry in INTERFACE CRITERIA file.",1:INDA)
+17 ;
NEW(INOPT,INCTRL) ; create new entry in INTERFACE CRITERIA file
+1 ;
+2 ; input: INOPT array. See INHUTCD for description.
+3 ; INCTRL = S, U, B, or W. control value of new record
+4 ; returns: ien of record in INTERFACE CRITERIA file
+5 ; if function does not complete, reason text is returned
+6 ;
+7 IF '$LENGTH($GET(INCTRL))
QUIT "NEW: Control value not supplied"
+8 NEW DIC,DIE,DLAYGO,DA,DR,X,Y,INDA,INI
+9 SET DIC=4001.1
SET DIC(0)="LF"
SET DLAYGO=4001.1
SET X="NEW"
+10 FOR INI=1:1:5
Begin DoDot:1
+11 IF $$SC^INHUTIL1
DO EN^DICN
+12 ;Branch for IHS
+13 IF '$$SC^INHUTIL1
SET DIC="^DIZ(4001.1,"
DO NEW^DICN
+14 SET (DA,INDA)=+Y
IF INDA<0
QUIT
+15 ; get lock on entry
+16 IF '$$LOCK^INHUTC(INDA,1,5)
SET INDA=0
IF INDA
SET INOPT("LOCK",INDA)=$GET(INOPT("LOCK",INDA))+1
End DoDot:1
IF INDA
QUIT
+17 IF INDA<0
QUIT "NEW: Entry could not be created"
+18 SET DIE=DIC
SET DR=".01///"_DA_";.02///^S X=DUZ;.03///"_INCTRL_";.09///^S X=DT"_$SELECT($LENGTH($GET(INOPT("TYPE"))):";.05///"_INOPT("TYPE"),1:"")
+19 SET DR=DR_$SELECT($LENGTH($GET(INOPT("FUNC"))):";.06///"_INOPT("FUNC"),1:"")_$SELECT($LENGTH($GET(INOPT("APP"))):";.08///"_INOPT("APP"),1:"")_";11///0;12///0"
+20 DO ^DIE
+21 QUIT INDA
+22 ;
SAVE(INOPT,INDA,INCTRL) ; save working record to user defined record
+1 QUIT $$SAVE^INHUTC11(.INOPT,$GET(INDA),$GET(INCTRL))
+2 ;
COPY(INFROM,INTO,INCTRL) ; copy search fields from one entry to another
+1 DO COPY^INHUTC11($GET(INFROM),$GET(INTO),$GET(INCTRL))
+2 QUIT
+3 ;
EDIT(INDA,INGALL) ; edit criteria entry
+1 QUIT $$EDIT^INHUTC11($GET(INDA),$GET(INGALL))
+2 ;