AGGWDEF ;VNGT/HS/ALA - Window definition ; 24 May 2010 11:47 AM
;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
;;
Q
;
EN(DATA,VFILE,TYPE) ;EP -- AGG GET WINDOW DEFINITION
;
;Input
; VFILE - The Window number or name
;
NEW UID,II,IEN,VFIL,VALUE,ORD,VDATA,VDATA1,VDATA2,BJ,CLEAR,CLRFLD,CN,FLDNM
NEW HELP,VDATA3,VFILN,VHELP,BN,AGGHELP,AGGHELPW,VFLD,VDATA9,SVFILN,SVFLD
NEW DEF,HDR,NOSAVE,REQ,RGFN,RGN,VAL,VFIEN,CASE,BATCH
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGWDEF",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGWDEF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S VFIEN=$G(VFILE,""),TYPE=$G(TYPE,"V")
;
S HDR="T00030VFILE_NAME^T00015VFILE_NUMBER^T00030DISPLAY_RPC^T00045DISPLAY_RPC_PARAM^T00030EDIT_RPC^T00045EDIT_RPC_PARAM^T00030INIT_TRIGGER_RPC^"
S HDR=HDR_"T00045INIT_TRIG_PARAM^T00030DELETE_RPC^T00045DELETE_RPC_PARAM^T00001FILTER^T00030VALID_RPC^"
S HDR=HDR_"T00030DISPLAY_COLUMN^T00030INTERNAL_COLUMN^I00003SIZE^T00001COL_TYPE_PEND^T00001COL_TYPE_VIEW^T00008CODE^T00001GROUP^T00001CODE_TYPE^T00030UPPER^T00030LOWER^"
S HDR=HDR_"T00030DEFAULT^T00001ACTION^T00001REQ_OPT^T00036EXCLUSION^T00001UNIQUE_VAL^T00003BATCH^T00045VALIDATION^T00030VALID_INPUT^T00020TABLE^T00001TABLE_LOOKUP^T00001PROV_SCREEN^T00150TABLE_SCREEN^"
;S HDR=HDR_"T00030DEFAULT^T00001ACTION^T00001REQ_OPT^T00036EXCLUSION^T00045VALIDATION^T00030VALID_INPUT^T00020TABLE^T00001TABLE_LOOKUP^T00001PROV_SCREEN^T00150TABLE_SCREEN^"
S HDR=HDR_"T00001TRIGGER^T00030TRIG_RPC^T00045TRIG_CODES^T00001TABLE_PRELOAD^T00001TABLE_LOOKUP_TYPE^T00003DEC_PLACES^T00030ALT_DISPLAY^T00030MULT_REF^T00045GROUP_NAME^I00003GRID_ORDER^"
S HDR=HDR_"T00030LINK_DATA_COL^T00045LINK_RPC^T00030LINK_PARAM^T00001NOSAVE^T00001CASE^T00250CLEAR_FIELDS^T01024HELP_TEXT"_$C(30)
S @DATA@(II)=HDR
;
I VFIEN="" D G DONE
. S VFIL=0
. F S VFIL=$O(^AGG(9009068.3,"D",TYPE,VFIL)) Q:'VFIL D
.. ; If it is a subdefinition for a multiple, it is retrieved from the
.. ; Master definition so don't need to retrieve data fields
.. I $$GET1^DIQ(9009068.3,VFIL_",",.07,"I") Q
.. I $$GET1^DIQ(9009068.3,VFIL_",",.03,"I")=1 Q
.. D VF(VFIL)
;
; If someone passes the name
I VFIEN'?.N S VFIEN=$$FIND1^DIC(9009068.3,"","MX",VFILE,"","","ERROR")
; If someone passes the file number
I $L(VFIEN)>6 S VFIEN=$$FIND1^DIC(9009068.3,"","MX",VFILE,"","","ERROR")
;
I VFIEN=0 S BMXSEC="Passed in file "_VFILE_" is not correct" Q
I $$GET1^DIQ(9009068.3,VFIEN_",",.03,"I")=1 S BMXSEC=VFILE_" is not active" Q
;
D VF(VFIEN)
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
VF(VFIL) ;EP
; Parameters
; VFILN - File Number
; ORD - Display Order number
;
NEW VFDATA,VFSDATA,MULTR,SFIL,VFSDATA2,FILTER,VALID,LINK,LRPC,LINP
NEW BQN,BQP,BQPARM,VFDATA2,PRMND,PNAM,PTYP,PORD
;
S VFDATA=^AGG(9009068.3,VFIL,0)
S VFDATA2=$G(^AGG(9009068.3,VFIL,2))
S FILTER=$S($D(^AGG(9009068.3,VFIL,7)):"Y",1:"N")
S VALID=$P($G(^AGG(9009068.3,VFIL,8)),U,1)
I $P(VFDATA,U,6)="D" Q
;
D PRMS(VFIL)
;
S VFILN=$P(VFDATA,U,2),SVFILN=$P(VFDATA,U,14)
S VALUE=$P(VFDATA,U,1)_U_VFILN_U_$P(VFDATA,U,4)_U_BQPARM(3)_U_$P(VFDATA,U,12)_U_BQPARM(4)_U_$P(VFDATA,U,13)_U_BQPARM(5)_U_$P(VFDATA2,U)_U_BQPARM(6)_U_FILTER_U_VALID
S ORD=""
F S ORD=$O(^AGG(9009068.3,VFIL,10,"C",ORD)) Q:ORD="" D
. S IEN=""
. F S IEN=$O(^AGG(9009068.3,VFIL,10,"C",ORD,IEN)) Q:IEN="" D
.. D RET(VFIL,IEN)
;
;Check for subdefinitions
S SFIL=""
F S SFIL=$O(^AGG(9009068.3,"ASUB",VFIL,SFIL)) Q:SFIL="" D
. ;S VFILN=$$GET1^DIQ(9009068.3,SFIL_",",.02,"E")
. ;S VALUE=$$GET1^DIQ(9009068.3,SFIL_",",.01,"E")_U_VFILN
. S VFSDATA=^AGG(9009068.3,SFIL,0)
. I $P(VFSDATA,U,3)=1 Q
. S VFSDATA2=$G(^AGG(9009068.3,VFIL,2))
. S FILTER=$S($D(^AGG(9009068.3,VFIL,7)):"Y",1:"N")
. S VALID=$P($G(^AGG(9009068.3,VFIL,8)),U,1)
. S VFILN=$P(VFSDATA,U,2),SVFILN=$P(VFSDATA,U,14)
. D PRMS(SFIL)
. ;S VALUE=$P(VFSDATA,U,1)_U_VFILN_U_$P(VFSDATA,U,4)_U_$P(VFSDATA,U,12)_U_$P(VFSDATA,U,13)
. S VALUE=$P(VFSDATA,U,1)_U_VFILN_U_$P(VFSDATA,U,4)_U_BQPARM(3)_U_$P(VFSDATA,U,12)_U_BQPARM(4)_U_$P(VFSDATA,U,13)_U_BQPARM(5)_U_$P(VFSDATA2,U)_U_BQPARM(6)_U_FILTER_U_VALID
. S ORD=""
. F S ORD=$O(^AGG(9009068.3,SFIL,10,"C",ORD)) Q:ORD="" D
.. S IEN=""
.. F S IEN=$O(^AGG(9009068.3,SFIL,10,"C",ORD,IEN)) Q:IEN="" D RET(SFIL,IEN)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
RET(VFIL,IEN) ; Retrieve data
S VDATA=^AGG(9009068.3,VFIL,10,IEN,0)
I $P(VDATA,U,11)=1 Q
S VDATA1=$G(^AGG(9009068.3,VFIL,10,IEN,1))
S VDATA2=$G(^AGG(9009068.3,VFIL,10,IEN,2))
S VDATA3=$G(^AGG(9009068.3,VFIL,10,IEN,3))
S VDATA9=$G(^AGG(9009068.3,VFIL,10,IEN,9))
NEW DA,IENS
S DA(1)=VFIL,DA=IEN,IENS=$$IENS^DILF(.DA)
S MULTR=$$GET1^DIQ(9009068.31,IENS,1.08,"E")
;
; Check for batch editable flag in 90506.1
;NEW CODE,LIEN,BATCH,LINK,LRPC,LINP
;S CODE=$P(VDATA,U,7),BATCH="NO"
S LRPC=$P(VDATA9,U,1),LINP=$P(VDATA9,U,2),LINK=$P(VDATA1,U,10),NOSAVE=$P(VDATA1,U,11),CASE=$P(VDATA1,U,12)
I NOSAVE="" S NOSAVE="N"
I CASE="" S CASE="U"
;S LIEN=$O(^AGG(90506.1,"B",CODE,""))
;I LIEN'="" D
;. S BATCH=+$$GET1^DIQ(90506.1,LIEN_",",.17,"I")
;. S BATCH=$S(BATCH=1:"YES",1:"NO")
;
;Check default field for API - $P(VDATA1,U,4)
S DEF=$P(VDATA1,U,4)
I DEF["$$" D
. NEW DVAL
. X DEF
. S $P(VDATA1,U,4)=DVAL
;
; Set the clear fields
S CLEAR="",CN=0,CLRFLD=""
F S CN=$O(^AGG(9009068.3,VFIL,10,IEN,10,CN)) Q:'CN D
. S CLEAR=CLEAR_$P(^AGG(9009068.3,VFIL,10,IEN,10,CN,0),"^",1)_";"
. S CLRFLD=$$TKO^AGGUL1(CLEAR,";")
;
; Set up the data fields
S VFLD=$P(VDATA3,U,1),SVFLD=$P(VDATA3,U,7)
S II=II+1,@DATA@(II)=VALUE_U_$P(VDATA,U,1,4)_U_$P(VDATA,U,12)_U_$P(VDATA,U,7)_U_$P(VDATA,U,14)_U
S REQ=$P(VDATA1,U,6)
F BJ=1:1:5 S @DATA@(II)=@DATA@(II)_$P(VDATA1,U,BJ)_U
;S PREQ=REQ
I SVFILN'="",SVFLD'="" D
. I SVFLD=.001 Q
. S FLDNM=$P(^DD(SVFILN,SVFLD,0),U,1)
. S RGN=$O(^AGFAC(DUZ(2),11,"B",SVFILN,"")) I RGN="" Q
. S RGFN=$O(^AGFAC(DUZ(2),11,RGN,1,"B",FLDNM,"")) I RGFN="" Q
. S VAL=$P(^AGFAC(DUZ(2),11,RGN,1,RGFN,0),U,2)
. S REQ=$S(VAL=0:"O",VAL=1:"R",1:REQ)
;
I VFILN'="",VFLD'="" D
. I VFLD=.001 Q
. S FLDNM=$P(^DD(VFILN,VFLD,0),U,1)
. ;I FLDNM="SOCIAL SECURITY NUMBER" S FLDNM="SSN"
. S RGN=$O(^AGFAC(DUZ(2),11,"B",VFILN,"")) I RGN="" Q
. S RGFN=$O(^AGFAC(DUZ(2),11,RGN,1,"B",FLDNM,"")) I RGFN="" Q
. S VAL=$P(^AGFAC(DUZ(2),11,RGN,1,RGFN,0),U,2)
. S REQ=$S(VAL=0:"",VAL=1:"R",1:REQ)
;
S @DATA@(II)=@DATA@(II)_REQ_U
F BJ=7,9 S @DATA@(II)=@DATA@(II)_$P(VDATA1,U,BJ)_U
S @DATA@(II)=@DATA@(II)_$G(BATCH)_U
F BJ=1:1:5 S @DATA@(II)=@DATA@(II)_$P(VDATA2,U,BJ)_U
S @DATA@(II)=@DATA@(II)_$G(^AGG(9009068.3,VFIL,10,IEN,6))_U_$P(VDATA,U,8)_U
S @DATA@(II)=@DATA@(II)_$P(VDATA,U,9)_U_$P(VDATA,U,10)_U_$P(VDATA2,U,6)_U_$P(VDATA2,U,9)_U
S @DATA@(II)=@DATA@(II)_$P(VDATA2,U,7)_U_$P(VDATA2,U,8)_U_MULTR_U_$P(VDATA3,U,4)_U
S @DATA@(II)=@DATA@(II)_$P(VDATA3,U,5)_U_LINK_U_LRPC_U_LINP_U_NOSAVE_U_CASE_U_CLRFLD_U
;
;Check for HELP text
K AGGHELPW,AGGHELP
S VFLD=$P(VDATA3,U,1),VHELP="",SVFLD=$P(VDATA3,U,7)
I SVFLD'="" D
. D FIELD^DID(SVFILN,SVFLD,"","HELP-PROMPT","AGGHELP")
. S VHELP=$G(AGGHELP("HELP-PROMPT"))
. I VHELP="" D
.. D FIELD^DID(SVFILN,SVFLD,"Z","DESCRIPTION","AGGHELPW")
.. I $G(AGGHELPW("DESCRIPTION"))="" Q
.. S BN=0,VHELP=""
.. F S BN=$O(AGGHELPW("DESCRIPTION",BN)) Q:BN="" D
... S VHELP=VHELP_AGGHELPW("DESCRIPTION",BN,0)_$C(10)
I VFLD'="" D
. D FIELD^DID(VFILN,VFLD,"","HELP-PROMPT","AGGHELP")
. S VHELP=$G(AGGHELP("HELP-PROMPT"))
. I VHELP="" D
.. D FIELD^DID(VFILN,VFLD,"Z","DESCRIPTION","AGGHELPW")
.. I $G(AGGHELPW("DESCRIPTION"))="" Q
.. S BN=0,VHELP=""
.. F S BN=$O(AGGHELPW("DESCRIPTION",BN)) Q:BN="" D
... S VHELP=VHELP_AGGHELPW("DESCRIPTION",BN,0)_$C(10)
I $P(VDATA3,U,6)'="" S VHELP=$P(VDATA3,U,6)
S @DATA@(II)=@DATA@(II)_VHELP_$C(30)
Q
;
USR() ;EP - Get the default user
Q DUZ_$C(28)_$P($G(^VA(200,DUZ,0)),U,1)
;
TBL(FILE,VALUE) ; EP - Get a default for a specific table value
NEW IEN
S IEN=$$FIND1^DIC(FILE,"","MX",VALUE,"","","ERROR")
Q IEN_$C(28)_VALUE
;
PRMS(VFIL) ;EP - Pull RPC parameters
F BQN=3:1:6 D
.S BQPARM(BQN)=""
.N IDT,PRM,TIDT,TPRM
.S BQP=0 F S BQP=$O(^AGG(9009068.3,VFIL,BQN,BQP)) Q:'BQP D
..S PRMND=$G(^AGG(9009068.3,VFIL,BQN,BQP,0))
..S PNAM=$P(PRMND,U)
..S PTYP=$P(PRMND,U,2) S:PTYP="" PTYP=$S(PNAM["=":"P",1:"I")
..S PORD=$P(PRMND,U,3) S:PORD="" PORD=BQP_PNAM
..;
..;Temp Store of Unique Identifiers
..I PTYP="I" D
...S TIDT(PORD)=PRMND
..;
..;Temp Store of Regular Parameters
..I PTYP="P" D
...S TPRM(PORD)=PRMND
.;
.;Form Parameter String
.S IDT="",BQP="" F S BQP=$O(TIDT(BQP)) Q:BQP="" S IDT=IDT_$S(IDT]"":";",1:"")_$P(TIDT(BQP),U)
.S PRM="",BQP="" F S BQP=$O(TPRM(BQP)) Q:BQP="" S PRM=PRM_$S(PRM]"":$C(28),1:"")_$P(TPRM(BQP),U)
.S BQPARM(BQN)=IDT_$S(IDT]"":";",1:"")_PRM
.S BQPARM(BQN)=$$TKO^AGGUL1(BQPARM(BQN),";")
Q
AGGWDEF ;VNGT/HS/ALA - Window definition ; 24 May 2010 11:47 AM
+1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
+2 ;;
+3 QUIT
+4 ;
EN(DATA,VFILE,TYPE) ;EP -- AGG GET WINDOW DEFINITION
+1 ;
+2 ;Input
+3 ; VFILE - The Window number or name
+4 ;
+5 NEW UID,II,IEN,VFIL,VALUE,ORD,VDATA,VDATA1,VDATA2,BJ,CLEAR,CLRFLD,CN,FLDNM
+6 NEW HELP,VDATA3,VFILN,VHELP,BN,AGGHELP,AGGHELPW,VFLD,VDATA9,SVFILN,SVFLD
+7 NEW DEF,HDR,NOSAVE,REQ,RGFN,RGN,VAL,VFIEN,CASE,BATCH
+8 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+9 SET DATA=$NAME(^TMP("AGGWDEF",UID))
+10 KILL @DATA
+11 SET II=0
+12 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGWDEF D UNWIND^%ZTER"
+13 ;
+14 SET VFIEN=$GET(VFILE,"")
SET TYPE=$GET(TYPE,"V")
+15 ;
+16 SET HDR="T00030VFILE_NAME^T00015VFILE_NUMBER^T00030DISPLAY_RPC^T00045DISPLAY_RPC_PARAM^T00030EDIT_RPC^T00045EDIT_RPC_PARAM^T00030INIT_TRIGGER_RPC^"
+17 SET HDR=HDR_"T00045INIT_TRIG_PARAM^T00030DELETE_RPC^T00045DELETE_RPC_PARAM^T00001FILTER^T00030VALID_RPC^"
+18 SET HDR=HDR_"T00030DISPLAY_COLUMN^T00030INTERNAL_COLUMN^I00003SIZE^T00001COL_TYPE_PEND^T00001COL_TYPE_VIEW^T00008CODE^T00001GROUP^T00001CODE_TYPE^T00030UPPER^T00030LOWER^"
+19 SET HDR=HDR_"T00030DEFAULT^T00001ACTION^T00001REQ_OPT^T00036EXCLUSION^T00001UNIQUE_VAL^T00003BATCH^T00045VALIDATION^T00030VALID_INPUT^T00020TABLE^T00001TABLE_LOOKUP^T00001PROV_SCREEN^T00150TABLE_SCREEN^"
+20 ;S HDR=HDR_"T00030DEFAULT^T00001ACTION^T00001REQ_OPT^T00036EXCLUSION^T00045VALIDATION^T00030VALID_INPUT^T00020TABLE^T00001TABLE_LOOKUP^T00001PROV_SCREEN^T00150TABLE_SCREEN^"
+21 SET HDR=HDR_"T00001TRIGGER^T00030TRIG_RPC^T00045TRIG_CODES^T00001TABLE_PRELOAD^T00001TABLE_LOOKUP_TYPE^T00003DEC_PLACES^T00030ALT_DISPLAY^T00030MULT_REF^T00045GROUP_NAME^I00003GRID_ORDER^"
+22 SET HDR=HDR_"T00030LINK_DATA_COL^T00045LINK_RPC^T00030LINK_PARAM^T00001NOSAVE^T00001CASE^T00250CLEAR_FIELDS^T01024HELP_TEXT"_$CHAR(30)
+23 SET @DATA@(II)=HDR
+24 ;
+25 IF VFIEN=""
Begin DoDot:1
+26 SET VFIL=0
+27 FOR
SET VFIL=$ORDER(^AGG(9009068.3,"D",TYPE,VFIL))
IF 'VFIL
QUIT
Begin DoDot:2
+28 ; If it is a subdefinition for a multiple, it is retrieved from the
+29 ; Master definition so don't need to retrieve data fields
+30 IF $$GET1^DIQ(9009068.3,VFIL_",",.07,"I")
QUIT
+31 IF $$GET1^DIQ(9009068.3,VFIL_",",.03,"I")=1
QUIT
+32 DO VF(VFIL)
End DoDot:2
End DoDot:1
GOTO DONE
+33 ;
+34 ; If someone passes the name
+35 IF VFIEN'?.N
SET VFIEN=$$FIND1^DIC(9009068.3,"","MX",VFILE,"","","ERROR")
+36 ; If someone passes the file number
+37 IF $LENGTH(VFIEN)>6
SET VFIEN=$$FIND1^DIC(9009068.3,"","MX",VFILE,"","","ERROR")
+38 ;
+39 IF VFIEN=0
SET BMXSEC="Passed in file "_VFILE_" is not correct"
QUIT
+40 IF $$GET1^DIQ(9009068.3,VFIEN_",",.03,"I")=1
SET BMXSEC=VFILE_" is not active"
QUIT
+41 ;
+42 DO VF(VFIEN)
+43 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
VF(VFIL) ;EP
+1 ; Parameters
+2 ; VFILN - File Number
+3 ; ORD - Display Order number
+4 ;
+5 NEW VFDATA,VFSDATA,MULTR,SFIL,VFSDATA2,FILTER,VALID,LINK,LRPC,LINP
+6 NEW BQN,BQP,BQPARM,VFDATA2,PRMND,PNAM,PTYP,PORD
+7 ;
+8 SET VFDATA=^AGG(9009068.3,VFIL,0)
+9 SET VFDATA2=$GET(^AGG(9009068.3,VFIL,2))
+10 SET FILTER=$SELECT($DATA(^AGG(9009068.3,VFIL,7)):"Y",1:"N")
+11 SET VALID=$PIECE($GET(^AGG(9009068.3,VFIL,8)),U,1)
+12 IF $PIECE(VFDATA,U,6)="D"
QUIT
+13 ;
+14 DO PRMS(VFIL)
+15 ;
+16 SET VFILN=$PIECE(VFDATA,U,2)
SET SVFILN=$PIECE(VFDATA,U,14)
+17 SET VALUE=$PIECE(VFDATA,U,1)_U_VFILN_U_$PIECE(VFDATA,U,4)_U_BQPARM(3)_U_$PIECE(VFDATA,U,12)_U_BQPARM(4)_U_$PIECE(VFDATA,U,13)_U_BQPARM(5)_U_$PIECE(VFDATA2,U)_U_BQPARM(6)_U_FILTER_U_VALID
+18 SET ORD=""
+19 FOR
SET ORD=$ORDER(^AGG(9009068.3,VFIL,10,"C",ORD))
IF ORD=""
QUIT
Begin DoDot:1
+20 SET IEN=""
+21 FOR
SET IEN=$ORDER(^AGG(9009068.3,VFIL,10,"C",ORD,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+22 DO RET(VFIL,IEN)
End DoDot:2
End DoDot:1
+23 ;
+24 ;Check for subdefinitions
+25 SET SFIL=""
+26 FOR
SET SFIL=$ORDER(^AGG(9009068.3,"ASUB",VFIL,SFIL))
IF SFIL=""
QUIT
Begin DoDot:1
+27 ;S VFILN=$$GET1^DIQ(9009068.3,SFIL_",",.02,"E")
+28 ;S VALUE=$$GET1^DIQ(9009068.3,SFIL_",",.01,"E")_U_VFILN
+29 SET VFSDATA=^AGG(9009068.3,SFIL,0)
+30 IF $PIECE(VFSDATA,U,3)=1
QUIT
+31 SET VFSDATA2=$GET(^AGG(9009068.3,VFIL,2))
+32 SET FILTER=$SELECT($DATA(^AGG(9009068.3,VFIL,7)):"Y",1:"N")
+33 SET VALID=$PIECE($GET(^AGG(9009068.3,VFIL,8)),U,1)
+34 SET VFILN=$PIECE(VFSDATA,U,2)
SET SVFILN=$PIECE(VFSDATA,U,14)
+35 DO PRMS(SFIL)
+36 ;S VALUE=$P(VFSDATA,U,1)_U_VFILN_U_$P(VFSDATA,U,4)_U_$P(VFSDATA,U,12)_U_$P(VFSDATA,U,13)
+37 SET VALUE=$PIECE(VFSDATA,U,1)_U_VFILN_U_$PIECE(VFSDATA,U,4)_U_BQPARM(3)_U_$PIECE(VFSDATA,U,12)_U_BQPARM(4)_U_$PIECE(VFSDATA,U,13)_U_BQPARM(5)_U_$PIECE(VFSDATA2,U)_U_BQPARM(6)_U_FILTER_U_VALID
+38 SET ORD=""
+39 FOR
SET ORD=$ORDER(^AGG(9009068.3,SFIL,10,"C",ORD))
IF ORD=""
QUIT
Begin DoDot:2
+40 SET IEN=""
+41 FOR
SET IEN=$ORDER(^AGG(9009068.3,SFIL,10,"C",ORD,IEN))
IF IEN=""
QUIT
DO RET(SFIL,IEN)
End DoDot:2
End DoDot:1
+42 QUIT
+43 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
RET(VFIL,IEN) ; Retrieve data
+1 SET VDATA=^AGG(9009068.3,VFIL,10,IEN,0)
+2 IF $PIECE(VDATA,U,11)=1
QUIT
+3 SET VDATA1=$GET(^AGG(9009068.3,VFIL,10,IEN,1))
+4 SET VDATA2=$GET(^AGG(9009068.3,VFIL,10,IEN,2))
+5 SET VDATA3=$GET(^AGG(9009068.3,VFIL,10,IEN,3))
+6 SET VDATA9=$GET(^AGG(9009068.3,VFIL,10,IEN,9))
+7 NEW DA,IENS
+8 SET DA(1)=VFIL
SET DA=IEN
SET IENS=$$IENS^DILF(.DA)
+9 SET MULTR=$$GET1^DIQ(9009068.31,IENS,1.08,"E")
+10 ;
+11 ; Check for batch editable flag in 90506.1
+12 ;NEW CODE,LIEN,BATCH,LINK,LRPC,LINP
+13 ;S CODE=$P(VDATA,U,7),BATCH="NO"
+14 SET LRPC=$PIECE(VDATA9,U,1)
SET LINP=$PIECE(VDATA9,U,2)
SET LINK=$PIECE(VDATA1,U,10)
SET NOSAVE=$PIECE(VDATA1,U,11)
SET CASE=$PIECE(VDATA1,U,12)
+15 IF NOSAVE=""
SET NOSAVE="N"
+16 IF CASE=""
SET CASE="U"
+17 ;S LIEN=$O(^AGG(90506.1,"B",CODE,""))
+18 ;I LIEN'="" D
+19 ;. S BATCH=+$$GET1^DIQ(90506.1,LIEN_",",.17,"I")
+20 ;. S BATCH=$S(BATCH=1:"YES",1:"NO")
+21 ;
+22 ;Check default field for API - $P(VDATA1,U,4)
+23 SET DEF=$PIECE(VDATA1,U,4)
+24 IF DEF["$$"
Begin DoDot:1
+25 NEW DVAL
+26 XECUTE DEF
+27 SET $PIECE(VDATA1,U,4)=DVAL
End DoDot:1
+28 ;
+29 ; Set the clear fields
+30 SET CLEAR=""
SET CN=0
SET CLRFLD=""
+31 FOR
SET CN=$ORDER(^AGG(9009068.3,VFIL,10,IEN,10,CN))
IF 'CN
QUIT
Begin DoDot:1
+32 SET CLEAR=CLEAR_$PIECE(^AGG(9009068.3,VFIL,10,IEN,10,CN,0),"^",1)_";"
+33 SET CLRFLD=$$TKO^AGGUL1(CLEAR,";")
End DoDot:1
+34 ;
+35 ; Set up the data fields
+36 SET VFLD=$PIECE(VDATA3,U,1)
SET SVFLD=$PIECE(VDATA3,U,7)
+37 SET II=II+1
SET @DATA@(II)=VALUE_U_$PIECE(VDATA,U,1,4)_U_$PIECE(VDATA,U,12)_U_$PIECE(VDATA,U,7)_U_$PIECE(VDATA,U,14)_U
+38 SET REQ=$PIECE(VDATA1,U,6)
+39 FOR BJ=1:1:5
SET @DATA@(II)=@DATA@(II)_$PIECE(VDATA1,U,BJ)_U
+40 ;S PREQ=REQ
+41 IF SVFILN'=""
IF SVFLD'=""
Begin DoDot:1
+42 IF SVFLD=.001
QUIT
+43 SET FLDNM=$PIECE(^DD(SVFILN,SVFLD,0),U,1)
+44 SET RGN=$ORDER(^AGFAC(DUZ(2),11,"B",SVFILN,""))
IF RGN=""
QUIT
+45 SET RGFN=$ORDER(^AGFAC(DUZ(2),11,RGN,1,"B",FLDNM,""))
IF RGFN=""
QUIT
+46 SET VAL=$PIECE(^AGFAC(DUZ(2),11,RGN,1,RGFN,0),U,2)
+47 SET REQ=$SELECT(VAL=0:"O",VAL=1:"R",1:REQ)
End DoDot:1
+48 ;
+49 IF VFILN'=""
IF VFLD'=""
Begin DoDot:1
+50 IF VFLD=.001
QUIT
+51 SET FLDNM=$PIECE(^DD(VFILN,VFLD,0),U,1)
+52 ;I FLDNM="SOCIAL SECURITY NUMBER" S FLDNM="SSN"
+53 SET RGN=$ORDER(^AGFAC(DUZ(2),11,"B",VFILN,""))
IF RGN=""
QUIT
+54 SET RGFN=$ORDER(^AGFAC(DUZ(2),11,RGN,1,"B",FLDNM,""))
IF RGFN=""
QUIT
+55 SET VAL=$PIECE(^AGFAC(DUZ(2),11,RGN,1,RGFN,0),U,2)
+56 SET REQ=$SELECT(VAL=0:"",VAL=1:"R",1:REQ)
End DoDot:1
+57 ;
+58 SET @DATA@(II)=@DATA@(II)_REQ_U
+59 FOR BJ=7,9
SET @DATA@(II)=@DATA@(II)_$PIECE(VDATA1,U,BJ)_U
+60 SET @DATA@(II)=@DATA@(II)_$GET(BATCH)_U
+61 FOR BJ=1:1:5
SET @DATA@(II)=@DATA@(II)_$PIECE(VDATA2,U,BJ)_U
+62 SET @DATA@(II)=@DATA@(II)_$GET(^AGG(9009068.3,VFIL,10,IEN,6))_U_$PIECE(VDATA,U,8)_U
+63 SET @DATA@(II)=@DATA@(II)_$PIECE(VDATA,U,9)_U_$PIECE(VDATA,U,10)_U_$PIECE(VDATA2,U,6)_U_$PIECE(VDATA2,U,9)_U
+64 SET @DATA@(II)=@DATA@(II)_$PIECE(VDATA2,U,7)_U_$PIECE(VDATA2,U,8)_U_MULTR_U_$PIECE(VDATA3,U,4)_U
+65 SET @DATA@(II)=@DATA@(II)_$PIECE(VDATA3,U,5)_U_LINK_U_LRPC_U_LINP_U_NOSAVE_U_CASE_U_CLRFLD_U
+66 ;
+67 ;Check for HELP text
+68 KILL AGGHELPW,AGGHELP
+69 SET VFLD=$PIECE(VDATA3,U,1)
SET VHELP=""
SET SVFLD=$PIECE(VDATA3,U,7)
+70 IF SVFLD'=""
Begin DoDot:1
+71 DO FIELD^DID(SVFILN,SVFLD,"","HELP-PROMPT","AGGHELP")
+72 SET VHELP=$GET(AGGHELP("HELP-PROMPT"))
+73 IF VHELP=""
Begin DoDot:2
+74 DO FIELD^DID(SVFILN,SVFLD,"Z","DESCRIPTION","AGGHELPW")
+75 IF $GET(AGGHELPW("DESCRIPTION"))=""
QUIT
+76 SET BN=0
SET VHELP=""
+77 FOR
SET BN=$ORDER(AGGHELPW("DESCRIPTION",BN))
IF BN=""
QUIT
Begin DoDot:3
+78 SET VHELP=VHELP_AGGHELPW("DESCRIPTION",BN,0)_$CHAR(10)
End DoDot:3
End DoDot:2
End DoDot:1
+79 IF VFLD'=""
Begin DoDot:1
+80 DO FIELD^DID(VFILN,VFLD,"","HELP-PROMPT","AGGHELP")
+81 SET VHELP=$GET(AGGHELP("HELP-PROMPT"))
+82 IF VHELP=""
Begin DoDot:2
+83 DO FIELD^DID(VFILN,VFLD,"Z","DESCRIPTION","AGGHELPW")
+84 IF $GET(AGGHELPW("DESCRIPTION"))=""
QUIT
+85 SET BN=0
SET VHELP=""
+86 FOR
SET BN=$ORDER(AGGHELPW("DESCRIPTION",BN))
IF BN=""
QUIT
Begin DoDot:3
+87 SET VHELP=VHELP_AGGHELPW("DESCRIPTION",BN,0)_$CHAR(10)
End DoDot:3
End DoDot:2
End DoDot:1
+88 IF $PIECE(VDATA3,U,6)'=""
SET VHELP=$PIECE(VDATA3,U,6)
+89 SET @DATA@(II)=@DATA@(II)_VHELP_$CHAR(30)
+90 QUIT
+91 ;
USR() ;EP - Get the default user
+1 QUIT DUZ_$CHAR(28)_$PIECE($GET(^VA(200,DUZ,0)),U,1)
+2 ;
TBL(FILE,VALUE) ; EP - Get a default for a specific table value
+1 NEW IEN
+2 SET IEN=$$FIND1^DIC(FILE,"","MX",VALUE,"","","ERROR")
+3 QUIT IEN_$CHAR(28)_VALUE
+4 ;
PRMS(VFIL) ;EP - Pull RPC parameters
+1 FOR BQN=3:1:6
Begin DoDot:1
+2 SET BQPARM(BQN)=""
+3 NEW IDT,PRM,TIDT,TPRM
+4 SET BQP=0
FOR
SET BQP=$ORDER(^AGG(9009068.3,VFIL,BQN,BQP))
IF 'BQP
QUIT
Begin DoDot:2
+5 SET PRMND=$GET(^AGG(9009068.3,VFIL,BQN,BQP,0))
+6 SET PNAM=$PIECE(PRMND,U)
+7 SET PTYP=$PIECE(PRMND,U,2)
IF PTYP=""
SET PTYP=$SELECT(PNAM["=":"P",1:"I")
+8 SET PORD=$PIECE(PRMND,U,3)
IF PORD=""
SET PORD=BQP_PNAM
+9 ;
+10 ;Temp Store of Unique Identifiers
+11 IF PTYP="I"
Begin DoDot:3
+12 SET TIDT(PORD)=PRMND
End DoDot:3
+13 ;
+14 ;Temp Store of Regular Parameters
+15 IF PTYP="P"
Begin DoDot:3
+16 SET TPRM(PORD)=PRMND
End DoDot:3
End DoDot:2
+17 ;
+18 ;Form Parameter String
+19 SET IDT=""
SET BQP=""
FOR
SET BQP=$ORDER(TIDT(BQP))
IF BQP=""
QUIT
SET IDT=IDT_$SELECT(IDT]"":";",1:"")_$PIECE(TIDT(BQP),U)
+20 SET PRM=""
SET BQP=""
FOR
SET BQP=$ORDER(TPRM(BQP))
IF BQP=""
QUIT
SET PRM=PRM_$SELECT(PRM]"":$CHAR(28),1:"")_$PIECE(TPRM(BQP),U)
+21 SET BQPARM(BQN)=IDT_$SELECT(IDT]"":";",1:"")_PRM
+22 SET BQPARM(BQN)=$$TKO^AGGUL1(BQPARM(BQN),";")
End DoDot:1
+23 QUIT
