- 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 ;