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

AGGWDEF.m

Go to the documentation of this file. 
  1. AGGWDEF ;VNGT/HS/ALA - Window definition ; 24 May 2010  11:47 AM
  1.  ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
  1.  ;;
  1.  Q
  1.  ;
  1. EN(DATA,VFILE,TYPE) ;EP -- AGG GET WINDOW DEFINITION
  1.  ;
  1.  ;Input
  1.  ;  VFILE - The Window number or name
  1.  ;
  1.  NEW UID,II,IEN,VFIL,VALUE,ORD,VDATA,VDATA1,VDATA2,BJ,CLEAR,CLRFLD,CN,FLDNM
  1.  NEW HELP,VDATA3,VFILN,VHELP,BN,AGGHELP,AGGHELPW,VFLD,VDATA9,SVFILN,SVFLD
  1.  NEW DEF,HDR,NOSAVE,REQ,RGFN,RGN,VAL,VFIEN,CASE,BATCH
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("AGGWDEF",UID))
  1.  K @DATA
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGWDEF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S VFIEN=$G(VFILE,""),TYPE=$G(TYPE,"V")
  1.  ;
  1.  S HDR="T00030VFILE_NAME^T00015VFILE_NUMBER^T00030DISPLAY_RPC^T00045DISPLAY_RPC_PARAM^T00030EDIT_RPC^T00045EDIT_RPC_PARAM^T00030INIT_TRIGGER_RPC^"
  1.  S HDR=HDR_"T00045INIT_TRIG_PARAM^T00030DELETE_RPC^T00045DELETE_RPC_PARAM^T00001FILTER^T00030VALID_RPC^"
  1.  S HDR=HDR_"T00030DISPLAY_COLUMN^T00030INTERNAL_COLUMN^I00003SIZE^T00001COL_TYPE_PEND^T00001COL_TYPE_VIEW^T00008CODE^T00001GROUP^T00001CODE_TYPE^T00030UPPER^T00030LOWER^"
  1.  S HDR=HDR_"T00030DEFAULT^T00001ACTION^T00001REQ_OPT^T00036EXCLUSION^T00001UNIQUE_VAL^T00003BATCH^T00045VALIDATION^T00030VALID_INPUT^T00020TABLE^T00001TABLE_LOOKUP^T00001PROV_SCREEN^T00150TABLE_SCREEN^"
  1.  ;S HDR=HDR_"T00030DEFAULT^T00001ACTION^T00001REQ_OPT^T00036EXCLUSION^T00045VALIDATION^T00030VALID_INPUT^T00020TABLE^T00001TABLE_LOOKUP^T00001PROV_SCREEN^T00150TABLE_SCREEN^"
  1.  S HDR=HDR_"T00001TRIGGER^T00030TRIG_RPC^T00045TRIG_CODES^T00001TABLE_PRELOAD^T00001TABLE_LOOKUP_TYPE^T00003DEC_PLACES^T00030ALT_DISPLAY^T00030MULT_REF^T00045GROUP_NAME^I00003GRID_ORDER^"
  1.  S HDR=HDR_"T00030LINK_DATA_COL^T00045LINK_RPC^T00030LINK_PARAM^T00001NOSAVE^T00001CASE^T00250CLEAR_FIELDS^T01024HELP_TEXT"_$C(30)
  1.  S @DATA@(II)=HDR
  1.  ;
  1.  I VFIEN="" D  G DONE
  1.  . S VFIL=0
  1.  . F  S VFIL=$O(^AGG(9009068.3,"D",TYPE,VFIL)) Q:'VFIL  D
  1.  .. ; If it is a subdefinition for a multiple, it is retrieved from the
  1.  .. ; Master definition so don't need to retrieve data fields
  1.  .. I $$GET1^DIQ(9009068.3,VFIL_",",.07,"I") Q
  1.  .. I $$GET1^DIQ(9009068.3,VFIL_",",.03,"I")=1 Q
  1.  .. D VF(VFIL)
  1.  ;
  1.  ; If someone passes the name
  1.  I VFIEN'?.N S VFIEN=$$FIND1^DIC(9009068.3,"","MX",VFILE,"","","ERROR")
  1.  ; If someone passes the file number
  1.  I $L(VFIEN)>6 S VFIEN=$$FIND1^DIC(9009068.3,"","MX",VFILE,"","","ERROR")
  1.  ;
  1.  I VFIEN=0 S BMXSEC="Passed in file "_VFILE_" is not correct" Q
  1.  I $$GET1^DIQ(9009068.3,VFIEN_",",.03,"I")=1 S BMXSEC=VFILE_" is not active" Q
  1.  ;
  1.  D VF(VFIEN)
  1.  ;
  1. DONE ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. VF(VFIL) ;EP
  1.  ; Parameters
  1.  ;   VFILN - File Number
  1.  ;   ORD   - Display Order number
  1.  ;   
  1.  NEW VFDATA,VFSDATA,MULTR,SFIL,VFSDATA2,FILTER,VALID,LINK,LRPC,LINP
  1.  NEW BQN,BQP,BQPARM,VFDATA2,PRMND,PNAM,PTYP,PORD
  1.  ;
  1.  S VFDATA=^AGG(9009068.3,VFIL,0)
  1.  S VFDATA2=$G(^AGG(9009068.3,VFIL,2))
  1.  S FILTER=$S($D(^AGG(9009068.3,VFIL,7)):"Y",1:"N")
  1.  S VALID=$P($G(^AGG(9009068.3,VFIL,8)),U,1)
  1.  I $P(VFDATA,U,6)="D" Q
  1.  ;
  1.  D PRMS(VFIL)
  1.  ;
  1.  S VFILN=$P(VFDATA,U,2),SVFILN=$P(VFDATA,U,14)
  1.  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
  1.  S ORD=""
  1.  F  S ORD=$O(^AGG(9009068.3,VFIL,10,"C",ORD)) Q:ORD=""  D
  1.  . S IEN=""
  1.  . F  S IEN=$O(^AGG(9009068.3,VFIL,10,"C",ORD,IEN)) Q:IEN=""  D
  1.  .. D RET(VFIL,IEN)
  1.  ;
  1.  ;Check for subdefinitions
  1.  S SFIL=""
  1.  F  S SFIL=$O(^AGG(9009068.3,"ASUB",VFIL,SFIL)) Q:SFIL=""  D
  1.  . ;S VFILN=$$GET1^DIQ(9009068.3,SFIL_",",.02,"E")
  1.  . ;S VALUE=$$GET1^DIQ(9009068.3,SFIL_",",.01,"E")_U_VFILN
  1.  . S VFSDATA=^AGG(9009068.3,SFIL,0)
  1.  . I $P(VFSDATA,U,3)=1 Q
  1.  . S VFSDATA2=$G(^AGG(9009068.3,VFIL,2))
  1.  . S FILTER=$S($D(^AGG(9009068.3,VFIL,7)):"Y",1:"N")
  1.  . S VALID=$P($G(^AGG(9009068.3,VFIL,8)),U,1)
  1.  . S VFILN=$P(VFSDATA,U,2),SVFILN=$P(VFSDATA,U,14)
  1.  . D PRMS(SFIL)
  1.  . ;S VALUE=$P(VFSDATA,U,1)_U_VFILN_U_$P(VFSDATA,U,4)_U_$P(VFSDATA,U,12)_U_$P(VFSDATA,U,13)
  1.  . 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
  1.  . S ORD=""
  1.  . F  S ORD=$O(^AGG(9009068.3,SFIL,10,"C",ORD)) Q:ORD=""  D
  1.  .. S IEN=""
  1.  .. F  S IEN=$O(^AGG(9009068.3,SFIL,10,"C",ORD,IEN)) Q:IEN=""  D RET(SFIL,IEN)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. RET(VFIL,IEN) ; Retrieve data
  1.  S VDATA=^AGG(9009068.3,VFIL,10,IEN,0)
  1.  I $P(VDATA,U,11)=1 Q
  1.  S VDATA1=$G(^AGG(9009068.3,VFIL,10,IEN,1))
  1.  S VDATA2=$G(^AGG(9009068.3,VFIL,10,IEN,2))
  1.  S VDATA3=$G(^AGG(9009068.3,VFIL,10,IEN,3))
  1.  S VDATA9=$G(^AGG(9009068.3,VFIL,10,IEN,9))
  1.  NEW DA,IENS
  1.  S DA(1)=VFIL,DA=IEN,IENS=$$IENS^DILF(.DA)
  1.  S MULTR=$$GET1^DIQ(9009068.31,IENS,1.08,"E")
  1.  ;
  1.  ; Check for batch editable flag in 90506.1
  1.  ;NEW CODE,LIEN,BATCH,LINK,LRPC,LINP
  1.  ;S CODE=$P(VDATA,U,7),BATCH="NO"
  1.  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)
  1.  I NOSAVE="" S NOSAVE="N"
  1.  I CASE="" S CASE="U"
  1.  ;S LIEN=$O(^AGG(90506.1,"B",CODE,""))
  1.  ;I LIEN'="" D
  1.  ;. S BATCH=+$$GET1^DIQ(90506.1,LIEN_",",.17,"I")
  1.  ;. S BATCH=$S(BATCH=1:"YES",1:"NO")
  1.  ;
  1.  ;Check default field for API - $P(VDATA1,U,4)
  1.  S DEF=$P(VDATA1,U,4)
  1.  I DEF["$$" D
  1.  . NEW DVAL
  1.  . X DEF
  1.  . S $P(VDATA1,U,4)=DVAL
  1.  ;
  1.  ; Set the clear fields
  1.  S CLEAR="",CN=0,CLRFLD=""
  1.  F  S CN=$O(^AGG(9009068.3,VFIL,10,IEN,10,CN)) Q:'CN  D
  1.  . S CLEAR=CLEAR_$P(^AGG(9009068.3,VFIL,10,IEN,10,CN,0),"^",1)_";"
  1.  . S CLRFLD=$$TKO^AGGUL1(CLEAR,";")
  1.  ;
  1.  ; Set up the data fields
  1.  S VFLD=$P(VDATA3,U,1),SVFLD=$P(VDATA3,U,7)
  1.  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
  1.  S REQ=$P(VDATA1,U,6)
  1.  F BJ=1:1:5 S @DATA@(II)=@DATA@(II)_$P(VDATA1,U,BJ)_U
  1.  ;S PREQ=REQ
  1.  I SVFILN'="",SVFLD'="" D
  1.  . I SVFLD=.001 Q
  1.  . S FLDNM=$P(^DD(SVFILN,SVFLD,0),U,1)
  1.  . S RGN=$O(^AGFAC(DUZ(2),11,"B",SVFILN,"")) I RGN="" Q
  1.  . S RGFN=$O(^AGFAC(DUZ(2),11,RGN,1,"B",FLDNM,"")) I RGFN="" Q
  1.  . S VAL=$P(^AGFAC(DUZ(2),11,RGN,1,RGFN,0),U,2)
  1.  . S REQ=$S(VAL=0:"O",VAL=1:"R",1:REQ)
  1.  ;
  1.  I VFILN'="",VFLD'="" D
  1.  . I VFLD=.001 Q
  1.  . S FLDNM=$P(^DD(VFILN,VFLD,0),U,1)
  1.  . ;I FLDNM="SOCIAL SECURITY NUMBER" S FLDNM="SSN"
  1.  . S RGN=$O(^AGFAC(DUZ(2),11,"B",VFILN,"")) I RGN="" Q
  1.  . S RGFN=$O(^AGFAC(DUZ(2),11,RGN,1,"B",FLDNM,"")) I RGFN="" Q
  1.  . S VAL=$P(^AGFAC(DUZ(2),11,RGN,1,RGFN,0),U,2)
  1.  . S REQ=$S(VAL=0:"",VAL=1:"R",1:REQ)
  1.  ;
  1.  S @DATA@(II)=@DATA@(II)_REQ_U
  1.  F BJ=7,9 S @DATA@(II)=@DATA@(II)_$P(VDATA1,U,BJ)_U
  1.  S @DATA@(II)=@DATA@(II)_$G(BATCH)_U
  1.  F BJ=1:1:5 S @DATA@(II)=@DATA@(II)_$P(VDATA2,U,BJ)_U
  1.  S @DATA@(II)=@DATA@(II)_$G(^AGG(9009068.3,VFIL,10,IEN,6))_U_$P(VDATA,U,8)_U
  1.  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
  1.  S @DATA@(II)=@DATA@(II)_$P(VDATA2,U,7)_U_$P(VDATA2,U,8)_U_MULTR_U_$P(VDATA3,U,4)_U
  1.  S @DATA@(II)=@DATA@(II)_$P(VDATA3,U,5)_U_LINK_U_LRPC_U_LINP_U_NOSAVE_U_CASE_U_CLRFLD_U
  1.  ;
  1.  ;Check for HELP text
  1.  K AGGHELPW,AGGHELP
  1.  S VFLD=$P(VDATA3,U,1),VHELP="",SVFLD=$P(VDATA3,U,7)
  1.  I SVFLD'="" D
  1.  . D FIELD^DID(SVFILN,SVFLD,"","HELP-PROMPT","AGGHELP")
  1.  . S VHELP=$G(AGGHELP("HELP-PROMPT"))
  1.  . I VHELP="" D
  1.  .. D FIELD^DID(SVFILN,SVFLD,"Z","DESCRIPTION","AGGHELPW")
  1.  .. I $G(AGGHELPW("DESCRIPTION"))="" Q
  1.  .. S BN=0,VHELP=""
  1.  .. F  S BN=$O(AGGHELPW("DESCRIPTION",BN)) Q:BN=""  D
  1.  ... S VHELP=VHELP_AGGHELPW("DESCRIPTION",BN,0)_$C(10)
  1.  I VFLD'="" D
  1.  . D FIELD^DID(VFILN,VFLD,"","HELP-PROMPT","AGGHELP")
  1.  . S VHELP=$G(AGGHELP("HELP-PROMPT"))
  1.  . I VHELP="" D
  1.  .. D FIELD^DID(VFILN,VFLD,"Z","DESCRIPTION","AGGHELPW")
  1.  .. I $G(AGGHELPW("DESCRIPTION"))="" Q
  1.  .. S BN=0,VHELP=""
  1.  .. F  S BN=$O(AGGHELPW("DESCRIPTION",BN)) Q:BN=""  D
  1.  ... S VHELP=VHELP_AGGHELPW("DESCRIPTION",BN,0)_$C(10)
  1.  I $P(VDATA3,U,6)'="" S VHELP=$P(VDATA3,U,6)
  1.  S @DATA@(II)=@DATA@(II)_VHELP_$C(30)
  1.  Q
  1.  ;
  1. USR() ;EP - Get the default user
  1.  Q DUZ_$C(28)_$P($G(^VA(200,DUZ,0)),U,1)
  1.  ;
  1. TBL(FILE,VALUE) ; EP - Get a default for a specific table value
  1.  NEW IEN
  1.  S IEN=$$FIND1^DIC(FILE,"","MX",VALUE,"","","ERROR")
  1.  Q IEN_$C(28)_VALUE
  1.  ;
  1. PRMS(VFIL) ;EP - Pull RPC parameters
  1.  F BQN=3:1:6 D
  1.  .S BQPARM(BQN)=""
  1.  .N IDT,PRM,TIDT,TPRM
  1.  .S BQP=0 F  S BQP=$O(^AGG(9009068.3,VFIL,BQN,BQP)) Q:'BQP  D
  1.  ..S PRMND=$G(^AGG(9009068.3,VFIL,BQN,BQP,0))
  1.  ..S PNAM=$P(PRMND,U)
  1.  ..S PTYP=$P(PRMND,U,2) S:PTYP="" PTYP=$S(PNAM["=":"P",1:"I")
  1.  ..S PORD=$P(PRMND,U,3) S:PORD="" PORD=BQP_PNAM
  1.  ..;
  1.  ..;Temp Store of Unique Identifiers
  1.  ..I PTYP="I" D
  1.  ...S TIDT(PORD)=PRMND
  1.  ..;
  1.  ..;Temp Store of Regular Parameters
  1.  ..I PTYP="P" D
  1.  ...S TPRM(PORD)=PRMND
  1.  .;
  1.  .;Form Parameter String
  1.  .S IDT="",BQP="" F  S BQP=$O(TIDT(BQP)) Q:BQP=""  S IDT=IDT_$S(IDT]"":";",1:"")_$P(TIDT(BQP),U)
  1.  .S PRM="",BQP="" F  S BQP=$O(TPRM(BQP)) Q:BQP=""  S PRM=PRM_$S(PRM]"":$C(28),1:"")_$P(TPRM(BQP),U)
  1.  .S BQPARM(BQN)=IDT_$S(IDT]"":";",1:"")_PRM
  1.  .S BQPARM(BQN)=$$TKO^AGGUL1(BQPARM(BQN),";")
  1.  Q