INHUTC2 ;bar; 29 May 97 14:50; Interface Criteria Internal Utilities (DD)
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;;COPYRIGHT 1997 SAIC
Q
;
CLRLK(INOPT,INDA) ; clear all accumulated locks
;
; input: INOPT array
; INDA = optional entry to not clear
; return: none
;
N H,I,Y
S Y=0 F S Y=$O(INOPT("LOCK",Y)) Q:'Y D
. S H=INOPT("LOCK",Y)
. I Y=$G(INDA) S H=H-1,INOPT("LOCK",Y)=1
. E K INOPT("LOCK",Y)
. F I=1:1:H S %=$$LOCK^INHUTC(Y,0)
Q
;
TASK ; this tag is the entry point when called thru taskman
; input: INOPT array as described at the top of INHUTC, required.
S %=$$RUN^INHUTC(.INOPT)
Q
;
AUSER(INDA,INDUZ,INTYPE,INCTRL,INAPP,INFUNC,INDEL) ; manage AUSER x-ref
;
; input: INDA = ien to 4001.1 file, required
; at least one of the next four is required
; INTYPE = value of CRITERIA TYPE field
; INCTRL = value of CONTROL field
; INAPP = value of APPLICATION field
; INFUNC = value of FUNCTION field
; INDEL = if TRUE kill x-ref, otherwize set x-ref, optional
;
Q:$G(INDA)<1
N INNULL S INNULL="INNULL"
I '$G(INDUZ) S INDUZ=$P(^DIZ(4001.1,INDA,0),U,2) S:'INDUZ INDUZ="NULL"
E S INNULL="INDUZ"
I '$L($G(INTYPE)) S INTYPE=$P(^DIZ(4001.1,INDA,0),U,5) S:'$L(INTYPE) INTYPE="NULL"
E S INNULL="INTYPE"
I '$L($G(INCTRL)) S INCTRL=$P(^DIZ(4001.1,INDA,0),U,3) S:'$L(INCTRL) INCTRL="NULL"
E S INNULL="INCTRL"
I '$L($G(INAPP)) S INAPP=$P(^DIZ(4001.1,INDA,0),U,8) S:'$L(INAPP) INAPP="NULL"
E S INNULL="INAPP"
I '$L($G(INFUNC)) S INFUNC=$P(^DIZ(4001.1,INDA,0),U,6) S:'$L(INFUNC) INFUNC="NULL"
E S INNULL="INFUNC"
I $G(INDEL) D Q
. K ^DIZ(4001.1,"AUSER",INDUZ,INTYPE,INCTRL,INAPP,INFUNC,INDA)
. ; W !,"K ^DIZ(4001.1,""AUSER"","_INDUZ_","_INTYPE_","_INCTRL_","_INAPP_","_INFUNC_","_INDA_")"
D
. N @INNULL Q:'$D(INNULL) S @INNULL="NULL"
. D AUSER(INDA,INDUZ,INTYPE,INCTRL,INAPP,INFUNC,1)
S ^DIZ(4001.1,"AUSER",INDUZ,INTYPE,INCTRL,INAPP,INFUNC,INDA)=""
; W !,"S ^DIZ(4001.1,""AUSER"","_INDUZ_","_INTYPE_","_INCTRL_","_INAPP_","_INFUNC_","_INDA_")="""""
Q
;
TYPE(INTYPE,INSRCH) ; validate CRITERIA TYPE field
; called from input transform file 4001.1, field .05
; also used in criteria mgmt functions
;
; input: INTYPE = value to validate
; INSRCH - 0 = validate for any type
; 1 = validate for search types only
; return: boolean TRUE or FALSE
;
Q:'$L($G(INTYPE)) 0
I $G(INSRCH) Q "^TRANSACTION^ERROR^"[(U_INTYPE_U)
Q "^TRANSACTION^ERROR^TEST^"[(U_INTYPE_U)
;
SPACEBAR(X) ; return x for spacebar in lookup
; called from PRELK node for file 4001.1, also used in criteria mgmt
; functions. INOPT array must be defined in env.
;
; input: X = input value from read
; returns: `ien or X if working entry was not created
;
I $D(INOPT)<10 Q X
N INY S INY=$$WORKREC^INHUTC1(.INOPT,0)
; kill screen, it won't let "W" go thru
I INY>0 S INY="`"_INY,DIC("S")="" Q INY
Q X
;
RDTGET ; update a WindowMan Screen while editing, PART 1
; assumes being called from WindowMan and those variables are defined
; Called before RDTSET to setup the proper values
;
; get start/end relative date
S DWDIPA(24.01,"STDTR")="",DWDIPA(24.02,"ENDTR")=""
; get aux start/end relative date
S DWDIPA(24.05,"AUSTDTR")="",DWDIPA(24.06,"AUENDTR")=""
Q
;
RDTSET ; update a WindowMan Screen while editing, PART 2
; assumes being called from WindowMan and those variables are defined
; RDTGET must be called first and on a separate line in a POST field
;
S:$L($G(DIPA("STDTR"))) DWSFLD(1)=$$RELDT^INHUTC2(DIPA("STDTR"),"PU")
S:$L($G(DIPA("ENDTR"))) DWSFLD(1.1)=$$RELDT^INHUTC2(DIPA("ENDTR"),"PU")
S:$L($G(DIPA("AUSTDTR"))) DWSFLD(15.01)=$$RELDT^INHUTC2(DIPA("AUSTDTR"),"PU")
S:$L($G(DIPA("AUENDTR"))) DWSFLD(15.02)=$$RELDT^INHUTC2(DIPA("AUENDTR"),"PU")
Q
;
RELDATE(INCRITDA) ; update relative date for start and end date
;
Q:'$G(INCRITDA)
N INS,INE,INAS,INAE
; relative date for start and end date
S INS=$G(^DIZ(4001.1,INCRITDA,24)),INE=$P(INS,U,2),INAS=$P(INS,U,5),INAE=$P(INS,U,6),INS=$P(INS,U,1)
S:$L(INS) ^DIZ(4001.1,INCRITDA,1)=$$RELDT^INHUTC2(INS)
S:$L(INE) ^DIZ(4001.1,INCRITDA,1.1)=$$RELDT^INHUTC2(INE)
; relative date for aux start and end date
S:$L(INAS) $P(^DIZ(4001.1,INCRITDA,15),U,1)=$$RELDT^INHUTC2(INAS)
S:$L(INAE) $P(^DIZ(4001.1,INCRITDA,15),U,2)=$$RELDT^INHUTC2(INAE)
Q
;
RELDT(INSTR,INFMT,INPMT) ; convert a relative date text string to FM
;
; this entry point is used from the DD which does not contain S and T
; Use $$RELDT^INHUTC21 entry point not this entry point
;
S INFMT=$G(INFMT)
; allow time in input string
S:'$F(INFMT,"T") INFMT=INFMT_"T"
; allow seconds in input string
S:'$F(INFMT,"S") INFMT=INFMT_"S"
Q $$RELDT^INHUTC21($G(INSTR),INFMT,$G(INPMT))
INHUTC2 ;bar; 29 May 97 14:50; Interface Criteria Internal Utilities (DD)
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;;COPYRIGHT 1997 SAIC
+4 QUIT
+5 ;
CLRLK(INOPT,INDA) ; clear all accumulated locks
+1 ;
+2 ; input: INOPT array
+3 ; INDA = optional entry to not clear
+4 ; return: none
+5 ;
+6 NEW H,I,Y
+7 SET Y=0
FOR
SET Y=$ORDER(INOPT("LOCK",Y))
IF 'Y
QUIT
Begin DoDot:1
+8 SET H=INOPT("LOCK",Y)
+9 IF Y=$GET(INDA)
SET H=H-1
SET INOPT("LOCK",Y)=1
+10 IF '$TEST
KILL INOPT("LOCK",Y)
+11 FOR I=1:1:H
SET %=$$LOCK^INHUTC(Y,0)
End DoDot:1
+12 QUIT
+13 ;
TASK ; this tag is the entry point when called thru taskman
+1 ; input: INOPT array as described at the top of INHUTC, required.
+2 SET %=$$RUN^INHUTC(.INOPT)
+3 QUIT
+4 ;
AUSER(INDA,INDUZ,INTYPE,INCTRL,INAPP,INFUNC,INDEL) ; manage AUSER x-ref
+1 ;
+2 ; input: INDA = ien to 4001.1 file, required
+3 ; at least one of the next four is required
+4 ; INTYPE = value of CRITERIA TYPE field
+5 ; INCTRL = value of CONTROL field
+6 ; INAPP = value of APPLICATION field
+7 ; INFUNC = value of FUNCTION field
+8 ; INDEL = if TRUE kill x-ref, otherwize set x-ref, optional
+9 ;
+10 IF $GET(INDA)<1
QUIT
+11 NEW INNULL
SET INNULL="INNULL"
+12 IF '$GET(INDUZ)
SET INDUZ=$PIECE(^DIZ(4001.1,INDA,0),U,2)
IF 'INDUZ
SET INDUZ="NULL"
+13 IF '$TEST
SET INNULL="INDUZ"
+14 IF '$LENGTH($GET(INTYPE))
SET INTYPE=$PIECE(^DIZ(4001.1,INDA,0),U,5)
IF '$LENGTH(INTYPE)
SET INTYPE="NULL"
+15 IF '$TEST
SET INNULL="INTYPE"
+16 IF '$LENGTH($GET(INCTRL))
SET INCTRL=$PIECE(^DIZ(4001.1,INDA,0),U,3)
IF '$LENGTH(INCTRL)
SET INCTRL="NULL"
+17 IF '$TEST
SET INNULL="INCTRL"
+18 IF '$LENGTH($GET(INAPP))
SET INAPP=$PIECE(^DIZ(4001.1,INDA,0),U,8)
IF '$LENGTH(INAPP)
SET INAPP="NULL"
+19 IF '$TEST
SET INNULL="INAPP"
+20 IF '$LENGTH($GET(INFUNC))
SET INFUNC=$PIECE(^DIZ(4001.1,INDA,0),U,6)
IF '$LENGTH(INFUNC)
SET INFUNC="NULL"
+21 IF '$TEST
SET INNULL="INFUNC"
+22 IF $GET(INDEL)
Begin DoDot:1
+23 KILL ^DIZ(4001.1,"AUSER",INDUZ,INTYPE,INCTRL,INAPP,INFUNC,INDA)
+24 ; W !,"K ^DIZ(4001.1,""AUSER"","_INDUZ_","_INTYPE_","_INCTRL_","_INAPP_","_INFUNC_","_INDA_")"
End DoDot:1
QUIT
+25 Begin DoDot:1
+26 NEW @INNULL
IF '$DATA(INNULL)
QUIT
SET @INNULL="NULL"
+27 DO AUSER(INDA,INDUZ,INTYPE,INCTRL,INAPP,INFUNC,1)
End DoDot:1
+28 SET ^DIZ(4001.1,"AUSER",INDUZ,INTYPE,INCTRL,INAPP,INFUNC,INDA)=""
+29 ; W !,"S ^DIZ(4001.1,""AUSER"","_INDUZ_","_INTYPE_","_INCTRL_","_INAPP_","_INFUNC_","_INDA_")="""""
+30 QUIT
+31 ;
TYPE(INTYPE,INSRCH) ; validate CRITERIA TYPE field
+1 ; called from input transform file 4001.1, field .05
+2 ; also used in criteria mgmt functions
+3 ;
+4 ; input: INTYPE = value to validate
+5 ; INSRCH - 0 = validate for any type
+6 ; 1 = validate for search types only
+7 ; return: boolean TRUE or FALSE
+8 ;
+9 IF '$LENGTH($GET(INTYPE))
QUIT 0
+10 IF $GET(INSRCH)
QUIT "^TRANSACTION^ERROR^"[(U_INTYPE_U)
+11 QUIT "^TRANSACTION^ERROR^TEST^"[(U_INTYPE_U)
+12 ;
SPACEBAR(X) ; return x for spacebar in lookup
+1 ; called from PRELK node for file 4001.1, also used in criteria mgmt
+2 ; functions. INOPT array must be defined in env.
+3 ;
+4 ; input: X = input value from read
+5 ; returns: `ien or X if working entry was not created
+6 ;
+7 IF $DATA(INOPT)<10
QUIT X
+8 NEW INY
SET INY=$$WORKREC^INHUTC1(.INOPT,0)
+9 ; kill screen, it won't let "W" go thru
+10 IF INY>0
SET INY="`"_INY
SET DIC("S")=""
QUIT INY
+11 QUIT X
+12 ;
RDTGET ; update a WindowMan Screen while editing, PART 1
+1 ; assumes being called from WindowMan and those variables are defined
+2 ; Called before RDTSET to setup the proper values
+3 ;
+4 ; get start/end relative date
+5 SET DWDIPA(24.01,"STDTR")=""
SET DWDIPA(24.02,"ENDTR")=""
+6 ; get aux start/end relative date
+7 SET DWDIPA(24.05,"AUSTDTR")=""
SET DWDIPA(24.06,"AUENDTR")=""
+8 QUIT
+9 ;
RDTSET ; update a WindowMan Screen while editing, PART 2
+1 ; assumes being called from WindowMan and those variables are defined
+2 ; RDTGET must be called first and on a separate line in a POST field
+3 ;
+4 IF $LENGTH($GET(DIPA("STDTR")))
SET DWSFLD(1)=$$RELDT^INHUTC2(DIPA("STDTR"),"PU")
+5 IF $LENGTH($GET(DIPA("ENDTR")))
SET DWSFLD(1.1)=$$RELDT^INHUTC2(DIPA("ENDTR"),"PU")
+6 IF $LENGTH($GET(DIPA("AUSTDTR")))
SET DWSFLD(15.01)=$$RELDT^INHUTC2(DIPA("AUSTDTR"),"PU")
+7 IF $LENGTH($GET(DIPA("AUENDTR")))
SET DWSFLD(15.02)=$$RELDT^INHUTC2(DIPA("AUENDTR"),"PU")
+8 QUIT
+9 ;
RELDATE(INCRITDA) ; update relative date for start and end date
+1 ;
+2 IF '$GET(INCRITDA)
QUIT
+3 NEW INS,INE,INAS,INAE
+4 ; relative date for start and end date
+5 SET INS=$GET(^DIZ(4001.1,INCRITDA,24))
SET INE=$PIECE(INS,U,2)
SET INAS=$PIECE(INS,U,5)
SET INAE=$PIECE(INS,U,6)
SET INS=$PIECE(INS,U,1)
+6 IF $LENGTH(INS)
SET ^DIZ(4001.1,INCRITDA,1)=$$RELDT^INHUTC2(INS)
+7 IF $LENGTH(INE)
SET ^DIZ(4001.1,INCRITDA,1.1)=$$RELDT^INHUTC2(INE)
+8 ; relative date for aux start and end date
+9 IF $LENGTH(INAS)
SET $PIECE(^DIZ(4001.1,INCRITDA,15),U,1)=$$RELDT^INHUTC2(INAS)
+10 IF $LENGTH(INAE)
SET $PIECE(^DIZ(4001.1,INCRITDA,15),U,2)=$$RELDT^INHUTC2(INAE)
+11 QUIT
+12 ;
RELDT(INSTR,INFMT,INPMT) ; convert a relative date text string to FM
+1 ;
+2 ; this entry point is used from the DD which does not contain S and T
+3 ; Use $$RELDT^INHUTC21 entry point not this entry point
+4 ;
+5 SET INFMT=$GET(INFMT)
+6 ; allow time in input string
+7 IF '$FIND(INFMT,"T")
SET INFMT=INFMT_"T"
+8 ; allow seconds in input string
+9 IF '$FIND(INFMT,"S")
SET INFMT=INFMT_"S"
+10 QUIT $$RELDT^INHUTC21($GET(INSTR),INFMT,$GET(INPMT))
