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

AGGARVAL.m

Go to the documentation of this file. 
  1. AGGARVAL ;VNGT/HS/BEE-AGG Alternate Resource RPC Calls ; 07 Apr 2010  7:05 PM
  1.  ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
  1.  ;
  1.  ;
  1. MCDELG(DATA,MDESD,MDEED,MDECV,MDELIG) ;EP -- AGG VALIDATE MEDICAID ELIG ENTRY
  1.  ;
  1.  ;Input
  1.  ;  MDESD - AGGMDESD - Medicaid Eligibility Start Date
  1.  ;  MDEED - AGGMDEED - Medicaid Eligibility End Date
  1.  ;  MDECV - AGGMDECV - Medicaid Eligibility Coverage
  1.  ;  MDELIG   - Current list of Eligibility Entries
  1.  ;
  1.  NEW UID,II,LIST,BN,BQ,AGGMDESD,AGGMDEED,AGGMDECV,RESULT,EXPDT,EFFDT
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("AGGARVAL",UID))
  1.  K @DATA
  1.  S II=0,MSG=""
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGARVAL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S @DATA@(II)="I00010RESULT^T00100ERROR"_$C(30)
  1.  ;
  1.  ; Get list of current eligibility entries
  1.  S MDELIG=$G(MDELIG,"")
  1.  I MDELIG="" D
  1.  . S LIST="",BN=""
  1.  . F  S BN=$O(MDELIG(BN)) Q:BN=""  S LIST=LIST_MDELIG(BN)
  1.  . K MDELIG
  1.  . S MDELIG=LIST
  1.  . K LIST
  1.  ;
  1.  ;Parse Parameters
  1.  S (AGGMDESD,AGGMDEED,AGGMDECV)=""
  1.  F BQ=1:1:$L(MDELIG,$C(28)) D
  1.  . N PDATA,NAME,VALUE,BP,BV
  1.  . S PDATA=$P(MDELIG,$C(28),BQ) Q:PDATA=""
  1.  . S NAME=$P(PDATA,"=",1) I NAME="" Q
  1.  . S VALUE=$P(PDATA,"=",2,99) Q:VALUE=""
  1.  . F BP=1:1:$L(VALUE,$C(29)) S BV=$P(VALUE,$C(29),BP),@NAME=$G(@NAME)_$S(BP=1:"",1:$C(29))_BV
  1.  ;
  1.  ;Reset Return Result
  1.  S RESULT="1^"
  1.  ;
  1.  ;If no current entries pass test
  1.  I AGGMDESD="" S II=II+1,@DATA@(II)=RESULT_$C(30) G DONE
  1.  ;
  1.  ;Convert dates
  1.  S MDESD=$$DATE^AGGUL1(MDESD) S:MDESD="" MDESD=9999999
  1.  S MDEED=$$DATE^AGGUL1(MDEED) S:MDEED="" MDEED=9999999
  1.  ;
  1.  ;Loop through current entries and check for overlap
  1.  ;
  1.  ;First check for the same coverage
  1.  F BQ=1:1:$L(AGGMDESD,$C(29)) D  I RESULT'="1^" Q
  1.  . ;
  1.  . ;Check for overlapping date range
  1.  . S EXPDT=$$DATE^AGGUL1($P($P(AGGMDEED,$C(29),BQ)," ")) S:EXPDT="" EXPDT=9999999
  1.  . S EFFDT=$$DATE^AGGUL1($P($P(AGGMDESD,$C(29),BQ)," ")) S:EFFDT="" EFFDT=0
  1.  . ;
  1.  . ;Cannot have same start date
  1.  . I MDESD=EFFDT S RESULT="-1^" Q
  1.  . ;
  1.  . ;Check coverage
  1.  . I MDECV'=$P(AGGMDECV,$C(29),BQ) Q
  1.  . ;
  1.  . ;Other date checks
  1.  . I MDESD'<EFFDT,MDESD'>EXPDT S RESULT="-1^" Q
  1.  . I MDEED'<EFFDT,MDEED'>EXPDT S RESULT="-1^" Q
  1.  . I MDESD<EFFDT,MDEED>EXPDT S RESULT="-1^" Q
  1.  . Q
  1.  I RESULT="-1^" S RESULT=RESULT_"YOU HAVE ENTERED A COVERAGE DATE RANGE WHICH OVERLAPS WITH ANOTHER ALREADY EXISTING FOR THIS PATIENT! THE ENTRY WILL NOT BE ALLOWED!"
  1.  ;
  1.  S II=II+1,@DATA@(II)=RESULT_$C(30)
  1.  ;
  1. DONE ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  ;
  1.  ;Clear out variables
  1.  F BQ=1:1:$L(MDELIG,$C(28)) S NAME=$P($P(MDELIG,$C(28),BQ),"=") I NAME]"" K @NAME
  1.  ;
  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. MCDACT(RIEN) ;Check if Medicaid Entry is Active
  1.  ;
  1.  ;Input: RIEN - ^AUPNMCD Pointer
  1.  ;Output: ACTIVE/INACTIVE
  1.  ;
  1.  N RESULT,IEN,EFFDT,EXPDT
  1.  ;
  1.  S (RESULT,IEN)=0 F  S IEN=$O(^AUPNMCD(RIEN,11,IEN)) Q:'IEN  D  I RESULT=1 Q
  1.  . S EFFDT=$$GET1^DIQ(9000004.11,IEN_","_RIEN_",",.01,"I") S:EFFDT="" EFFDT=0
  1.  . S EXPDT=$$GET1^DIQ(9000004.11,IEN_","_RIEN_",",.02,"I") S:EXPDT="" EXPDT=9999999
  1.  . I DT'<EFFDT,DT'>EXPDT S RESULT=1
  1.  ;
  1.  S RESULT=$S(RESULT=1:"ACTIVE",1:"INACTIVE")
  1.  Q RESULT
  1.  ;
  1. MCRACT(DFN) ;Check if Medicare Entry is Active
  1.  ;
  1.  ;Input: DFN - ^AUPNMCR Pointer
  1.  ;Output: ACTIVE/INACTIVE/Null-For no Medicare
  1.  ;
  1.  N RESULT,IEN,EFFDT,EXPDT
  1.  ;
  1.  I '$D(^AUPNMCR(DFN)) Q ""
  1.  S (RESULT,IEN)=0 F  S IEN=$O(^AUPNMCR(DFN,11,IEN)) Q:'IEN  D  I RESULT=1 Q
  1.  . S EFFDT=$$GET1^DIQ(9000003.11,IEN_","_DFN_",",.01,"I") S:EFFDT="" EFFDT=0
  1.  . S EXPDT=$$GET1^DIQ(9000003.11,IEN_","_DFN_",",.02,"I") S:EXPDT="" EXPDT=9999999
  1.  . I DT'<EFFDT,DT'>EXPDT S RESULT=1
  1.  ;
  1.  S RESULT=$S(RESULT=1:"ACTIVE",1:"INACTIVE")
  1.  Q RESULT
  1.  ;
  1. PVTACT(IENS) ;Check if Private Insurance entry is active for patient
  1.  ;Check member info first and if blank look at policy holder info
  1.  ; 
  1.  ;Input: IENS - Lookup string to ^AUPNPRVT entry
  1.  ;Ouput: ACTIVE/INACTIVE/Null - For no information
  1.  NEW POLIEN,EFFDT,EXPDT,RESULT
  1.  ;
  1.  I $G(IENS)="" Q ""
  1.  S RESULT=""
  1.  ;
  1.  ;First look for member effective/expiration dates
  1.  S EFFDT=$$GET1^DIQ(9000006.11,IENS,.06,"I")
  1.  S EXPDT=$$GET1^DIQ(9000006.11,IENS,.07,"I")
  1.  I EFFDT]""!(EXPDT]"") D  Q RESULT
  1.  . S:EFFDT="" EFFDT=0
  1.  . S:EXPDT="" EXPDT=9999999
  1.  . I DT'<EFFDT,DT'>EXPDT S RESULT="ACTIVE" Q
  1.  . S RESULT="INACTIVE"
  1.  ;
  1.  ;If no member effective/expiration dates look at policy holder
  1.  S POLIEN=$$GET1^DIQ(9000006.11,IENS,.08,"I")
  1.  I POLIEN="" Q ""
  1.  S EFFDT=$$GET1^DIQ(9000003.1,POLIEN_",",.17,"I") S:EFFDT="" EFFDT=0
  1.  S EXPDT=$$GET1^DIQ(9000003.1,POLIEN_",",.18,"I") S:EXPDT="" EXPDT=9999999
  1.  I DT'<EFFDT,DT'>EXPDT Q "ACTIVE"
  1.  Q "INACTIVE"
  1.  ;
  1. INIT(DATA,RIEN,DFN) ;EP - AGG MEDICAID INIT TRIG
  1.  ; Input
  1.  ;   RIEN - Pointer to the Patient's Medicaid Entry
  1.  ;   DFN - Patient IEN
  1.  ;
  1.  NEW UID,II,HDR,SOURCE,HELP,TYPE,VALUE,ABLE,VISIBLE
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("AGGUPMCR",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0,RIEN=$G(RIEN)
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGARVAL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  D HDR^AGGWTRIG
  1.  S @DATA@(II)=HDR_$C(30)
  1.  ;
  1.  S RIEN=$G(RIEN)
  1.  ;
  1.  ;Always disable Date of Last Update field
  1.  S SOURCE="AGGLSTDT",HELP="",TYPE="D",VALUE="" S:RIEN]"" VALUE=$$FMTE^AGGUL1($$GET1^DIQ(9000004,RIEN_",",.08,"I")) S ABLE="N" S:VALUE="" VISIBLE="N" D UP^AGGWTRIG
  1.  S:RIEN="" SOURCE="AGGMDNME",HELP="",TYPE="X",VALUE=$$GET1^DIQ(2,DFN_",",.01,"E"),ABLE="Y",VISIBLE="Y" D UP^AGGWTRIG
  1.  S:RIEN="" SOURCE="AGGMDDOB",HELP="",TYPE="D",VALUE=$$FMTE^AGGUL1($$GET1^DIQ(2,DFN_",",.03,"I")),ABLE="Y",VISIBLE="Y" D UP^AGGWTRIG
  1.  ;
  1. XINIT S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. VAL(DATA,VFILE,PARMS) ;EP -- AGG MEDICARE ELIG VAL
  1.  ;
  1.  ;Input
  1.  ;  VFILE - The vfile number or name
  1.  ;  PARMS - The parameters being checked for validation
  1.  ;
  1.  NEW UID,II,BQ,LIST,BN,PDATA,NAME,VALUE,HDR,CODN,VALID,VALFLD,BI,VFLD,TYPE,X,RESULT,AGGMCCOV
  1.  NEW VFIEN,MSG,HNDLR,IEN,CODE,REVAL,MCELIG
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("AGGARVAL",UID))
  1.  K @DATA
  1.  S II=0,MSG=""
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGARVAL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S VFILE=$G(VFILE,"") I VFILE="" S BMXSEC="RPC Failed: No Window selected" Q
  1.  S VFIEN=$O(^AGG(9009068.3,"B",VFILE,""))
  1.  ;
  1.  S @DATA@(II)="I00010RESULT^T00100MSG^T00001HANDLER^I00010IEN^T00008CODE^T00100REVALIDATE"_$C(30)
  1.  ; Get list of parameters
  1.  S PARMS=$G(PARMS,"")
  1.  I PARMS="" D
  1.  . S LIST="",BN=""
  1.  . F  S BN=$O(PARMS(BN)) Q:BN=""  S LIST=LIST_PARMS(BN)
  1.  . K PARMS
  1.  . S PARMS=LIST
  1.  . K LIST
  1.  ;
  1.  I PARMS="" S II=II+1,@DATA@(II)="1^"_$G(MSG)_U_$G(HNDLR)_U_$G(IEN)_U_$G(CODE)_U_$G(REVAL)_$C(30) G XDONE
  1.  ;
  1.  ;Special Handling for Type of Coverage Validation - Multiple Field Passed
  1.  I $P($P(PARMS,$C(28)),"=")="AGGMCCOV" D
  1.  .S AGGMCCOV=$P($P(PARMS,$C(28)),"=",2)
  1.  .S MCELIG=$P(PARMS,"MCELIG=",2)
  1.  .S CODN=$O(^AGG(9009068.3,VFIEN,10,"B","Type of Coverage","")) Q:CODN=""
  1.  .S VALID=$P($G(^AGG(9009068.3,VFIEN,10,CODN,2)),U,2)
  1.  .S VALFLD=$P($G(^AGG(9009068.3,VFIEN,10,CODN,2)),U,1)
  1.  ;
  1.  ;Regular Parameter Parsing
  1.  I $P($P(PARMS,$C(28)),"=")'="AGGMCCOV" F BQ=1:1:$L(PARMS,$C(28)) D  Q:$G(BMXSEC)'=""
  1.  . S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
  1.  . S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
  1.  . I NAME["{"!(NAME["}") S NAME=$$STRIP^XLFSTR(NAME,"{}")
  1.  . S @NAME=VALUE
  1.  . ; If value is DFN, it exists at the PCC Visit level not individual
  1.  . ; V File level.
  1.  . I VFILE'=9000010&(NAME="DFN"!(NAME="APCDDATE")) Q
  1.  . S CODN=$O(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
  1.  . I CODN="" S BMXSEC="RPC Failed: Parameter does not exist for this Window" Q
  1.  . I $G(VALID)="" S VALID=$P($G(^AGG(9009068.3,VFIEN,10,CODN,2)),U,2)
  1.  . I $G(VALFLD)="" S VALFLD=$P($G(^AGG(9009068.3,VFIEN,10,CODN,2)),U,1)
  1.  ;
  1.  ; Check that values exist for all fields needed for the validation
  1.  F BI=1:1:$L(VALFLD,";") S VFLD=$P(VALFLD,";",BI) D
  1.  . I VFLD["*" S VFLD=$$STRIP^XLFSTR(VFLD,"*") Q
  1.  . I VFLD["{"!(VFLD["}") S VFLD=$$STRIP^XLFSTR(VFLD,"{}") Q
  1.  . I $G(@VFLD)="" S BMXSEC="RPC Failed: Missing validation value for "_VFLD
  1.  I $G(BMXSEC)'="" Q
  1.  ;
  1.  S VALID=$TR(VALID,"~","^"),RESULT=0
  1.  ; Execute the validation tag
  1.  D @VALID
  1.  S II=II+1,@DATA@(II)=RESULT_U_$G(MSG)_U_$G(HNDLR)_U_$G(IEN)_U_$G(CODE)_U_$G(REVAL)_$C(30)
  1.  ; Clean up validation variables
  1.  F BI=1:1:$L(VALFLD,";") D
  1.  . S VFLD=$P(VALFLD,";",BI),VFLD=$$STRIP^XLFSTR(VFLD,"*"),VFLD=$$STRIP^XLFSTR(VFLD,"{}")
  1.  . K @VFLD
  1.  ;
  1. XDONE ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  S NAME=""
  1.  F  S NAME=$O(^AGG(9009068.3,VFIEN,10,"AC",NAME)) Q:NAME=""  K @NAME
  1.  Q
  1.  ;
  1. PRTD(TYPCV,MCELIG) ;EP - New Part D Check for current Part A/B
  1.  N BQ
  1.  S RESULT=-1,MSG=""
  1.  I TYPCV'="D" S RESULT=1 Q
  1.  F BQ=1:1:$L(MCELIG,$C(28)) D  Q:RESULT=1
  1.  . N PDATA,NAME,VALUE,I
  1.  . S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
  1.  . S NAME=$P(PDATA,"=",1)
  1.  . Q:NAME'="AGGMCCOV"
  1.  . S VALUE=$P(PDATA,"=",2,99)
  1.  . F I=1:1:$L(VALUE,$C(29)) I $P(VALUE,$C(29),I)="A"!($P(VALUE,$C(29),I)="B") S RESULT=1 Q
  1.  Q:RESULT=1
  1.  S MSG="Patient must have Medicare Part A or Part B before being eligible for Part D"
  1.  Q
  1.  ;
  1. DTEMS(STRT,END) ; EP - Elig dates validation for Medicare
  1.  S RESULT=1
  1.  S STRT=$$DATE^AGGUL1(STRT),END=$$DATE^AGGUL1(END)
  1.  I $G(STRT)'="",2600000>STRT S RESULT=-1,MSG="Start Date cannot be before 1960" Q
  1.  I $G(STRT)'="",DT+20000<STRT S RESULT=-1,MSG="Start Date cannot be greater than 2 years from today" Q
  1.  ;
  1.  I $G(STRT)'="",$G(END)="" Q
  1.  I $G(STRT)'="",$G(END)'="",STRT<END S RESULT=1 Q
  1.  I $G(STRT)'="",$G(END)'="",STRT>END S RESULT=-1,MSG="Starting date cannot be greater than the Ending date" Q
  1.  Q
  1.  ;
  1. DTEME(END,STRT) ; EP
  1.  S RESULT=1
  1.  S STRT=$$DATE^AGGUL1(STRT),END=$$DATE^AGGUL1(END)
  1.  I $G(END)'="",2600000>END S RESULT=-1,MSG="End Date cannot be before 1960" Q
  1.  I $G(END)'="",DT+20000<END S RESULT=-1,MSG="End Date cannot be greater than 2 years from today" Q
  1.  ;
  1.  I $G(STRT)'="",$G(END)="" Q
  1.  I $G(STRT)'="",$G(END)'="",STRT<END S RESULT=1 Q
  1.  I $G(STRT)'="",$G(END)'="",STRT>END S RESULT=-1,MSG="Ending date cannot be less than the Starting date" Q
  1.  Q