Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: INHUTC1

INHUTC1.m

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