AGUTILS ;IHS/ASDS/TPF - PAT REG UTILITY ROUTINE ; 3/25/2004 8:25:20 AM
;;7.1;PATIENT REGISTRATION;**1,2,4,5**;JAN 31, 2007
;
Q
UPDTEMAL(PATDFN) ;EP - UPDATE HISTORICAL EMAIL ADDRESS
N ADDREC
K DIE,DIC,DR,DA,DIR
S DA(1)=PATDFN
S DIC="^AUPNPAT("_DA(1)_",82,"
S DIC(0)="L"
S X=""""_DT_""""
D ^DIC
I Y<0 D Q
.W !!,"HISTORICAL EMAIL ADDRESS COULD NOT BE UPDATED!!"
.K DIE,DIC,DR,DA,DIR
.S DIR(0)="E"
.D ^DIR
S ADDREC=+Y
N AGEMAIL
S AGEMAIL=$$GET1^DIQ(9000001,PATDFN_",",1802)
K DIE,DIC,DR,DA,DIR
S DA=ADDREC
S DA(1)=PATDFN
S DIE="^AUPNPAT("_DA(1)_",82,"
S DR=".02///^S X=AGEMAIL;"
D ^DIE
K DIE,DIC,DR,DA,DIR
;
Q
;FORCE MEANS USE //// TO FORCE THE DATA INTO THE NEW FIELDS
;THIS IS USED ONLY ON THE POST INSTALL TO ACCEPT BAD DATA ENTERED BY SITES
;USUALLY INTO THE CITY FIELD. iF FORCE="F" THEN FORCE
UPDTHADD(PATDFN,FORCE) ;EP - UPDATE HISTORICAL ADDRESS FROM FILE #2 ADRESS FIELDS
S FORCE=$G(FORCE)
I FORCE="F" Q:$O(^AUPNPAT(PATDFN,83,0)) ;F MEANS CALLED FROM POST INSTALL. QUIT IF THEY ALREADY HAVE AN HIST. ADDRESS. TAKES CARE OF BETA SITES
N ADDREC
K DIE,DIC,DR,DA,DIR
S DA(1)=PATDFN
S DIC="^AUPNPAT("_DA(1)_",83,"
S DIC(0)="L"
S X=""""_DT_""""
D ^DIC
I Y<0 D Q
.W !!,"HISTORICAL ADDRESS COULD NOT BE UPDATED!!"
.K DIE,DIC,DR,DA,DIR
.S DIR(0)="E"
.D ^DIR
S ADDREC=+Y
;
;get the current ADDRESS VALUES
N AGSTR1,STREET2,STREET3,CITY,STATE,ZIP,HPHONE
S AGSTR1=$$GET1^DIQ(2,PATDFN_",",.111)
S AGSTR2=$$GET1^DIQ(2,PATDFN_",",.112)
S AGSTR3=$$GET1^DIQ(2,PATDFN_",",.113)
S AGCITY=$$GET1^DIQ(2,PATDFN_",",.114)
S AGSTATE=$$GET1^DIQ(2,PATDFN_",",.115)
I $G(AGSTATE)'="" I AGSTATE'=+AGSTATE S AGSTATE=$O(^DIC(5,"B",AGSTATE,""))
S AGZIP=$$GET1^DIQ(2,PATDFN_",",.116)
S AGHPHONE=$$GET1^DIQ(2,PATDFN_",",.131)
;
K DIE,DIC,DR,DA,DIR
S DA=ADDREC
S DA(1)=PATDFN
S DIE="^AUPNPAT("_DA(1)_",83,"
;I FORCE="F" S DR=".02////AGSTR1;"
I FORCE="F" S DR=".02////"_AGSTR1_";"
E S DR=".02///^S X=AGSTR1;"
;I FORCE="F" S DR=DR_".03////AGSTR2;"
I FORCE="F" S DR=DR_".03////"_AGSTR2_";"
E S DR=DR_".03///^S X=AGSTR2;"
;I FORCE="F" S DR=DR_".04////AGSTR3;"
I FORCE="F" S DR=DR_".04////"_AGSTR3_";"
E S DR=DR_".04///^S X=AGSTR3;"
;I FORCE="F" S DR=DR_".05////AGCITY;"
I FORCE="F" S DR=DR_".05////"_AGCITY_";"
E S DR=DR_".05///^S X=AGCITY;"
;I FORCE="F" S DR=DR_".06////AGSTATE;"
I FORCE="F" S DR=DR_".06////"_AGSTATE_";"
E S DR=DR_".06///^S X=AGSTATE;"
;I FORCE="F" S DR=DR_".07////AGZIP;"
I FORCE="F" S DR=DR_".07////"_AGZIP_";"
E S DR=DR_".07///^S X=AGZIP;"
;I FORCE="F" S DR=DR_".08////AGHPHONE"
I FORCE="F" S DR=DR_".08////"_AGHPHONE_""
E S DR=DR_".08///^S X=AGHPHONE"
D ^DIE
K DIE,DIC,DR,DA,DIR
Q
;
;SEND ALERT MESSAGE
ALERTMSG(XMDUZ,XMY,XMSUB,XMTEXT) ;EP
D ^XMD
I $G(XMMG)'="" W !,XMMG H 2
Q
WRAP(X,DIWL,DIWF) ;EP - WRAP TEXT #DEV DISPLAY
K ^UTILITY($J,"W")
D ^DIWP
D ^DIWW
Q
;IS MANDATORY SEQUENCING TURNED ON?
;FIELD ^AGFAC(D0,21)= (#2101) MANDATORY SEQUENCING IN REGISTRATION PARAMETER FILE
SEQMAN(FAC) ;EP - IS MANDATORY SEQUENCING TURNED ON?
Q $P($G(^AGFAC(FAC,21)),U)
;DOES THE PATIENT HAVE A SEQUENCE SET UP?
PATSEQ(DFN) ;EP
Q $D(^AUPNICP("C",DFN))
;DOES THE USER NEED TO SEQUENCE?
NEEDTOSQ(DFN,FAC) ;EP - DOES THE USER NEED TO SEQUENCE?
N TRUE
S TRUE=$$SEQMAN(FAC)&('$$PATSEQ(DFN))
Q TRUE
;INPUT TRANSFORM FOR E-MAIL FIELDS. CHECK FOR VALID E-MAIL ADDRESS
EMAIL ;EP - CHECK FOR VALID E-MAIL ADDRESS
N HOST,NAME
;CHECK FOR .EXT SHOULD BE 2 OR THREE CHARS AT THE END AFTER "."
S EXTENT=$P(X,".",$L(X,"."))
I $L(X)<3 K X Q ;MINIMUM IS X@X
I $L(X)>65 K X Q ;TOTAL LENGTH CANNOT EXCEED 65
I X'[("@") K X Q ;GENERAL PATTERN OF 'XXXX@XXXX'
I $L(X,"@")'=2 K X Q ;MUST HAVE JUST ONE "@"
S HOST=$P(X,"@",2)
S NAME=$P(X,"@")
;NAME MUST END IN ALPHA OR NUMERIC
I '($E(NAME,$L(NAME))?1A)&'($E(NAME,$L(NAME))?1N) K X Q
;HOST MUST BEGIN WITH ALPHA OR NUMERIC
I '($E(HOST)?1A)&'($E(HOST)?1N) K X Q
I HOST'[(".") K X Q
;THE FOLLOWING CHARACTER PAIRS ARE NOT ALLOWED
I X[(".-") K X Q
I X[("-.") K X Q
I X[("-.") K X Q
I X[("--") K X Q
I X[("..") K X Q
I X[("._") K X Q
I X[("-_") K X Q
I X[("_.") K X Q
I X[("_-") K X Q
I X[("__") K X Q
;THE FOLLOWING CHARACTERS ARE NOT ALLOWED
I X[(",") K X Q
I X[(";") K X Q
I X[(":") K X Q
I X[("(") K X Q
I X[(")") K X Q
I X[("=") K X Q
I X[("+") K X Q
I X[("!") K X Q
I X[("<") K X Q
I X[(">") K X Q
I X[("?") K X Q
I X[("/") K X Q
I X[("\") K X Q
Q
VALPHONE ;EP - CHECK FOR VALID PHONE ENTRY
N GOOD,EXT
S GOOD=0
S REGPH=X
I REGPH[("EXT") S REGPH=$TR($P(REGPH,"EXT")," ") I $TR($P(X,"EXT",2)," ")="" S X=REGPH
I REGPH[("ext") S REGPH=$TR($P(REGPH,"ext")," ") I $TR($P(X,"ext",2)," ")="" S X=REGPH
S GOOD=REGPH?4N I GOOD Q ;extension only
S GOOD=REGPH?3N1"-"4N I GOOD Q
S GOOD=REGPH?3N1"-"3N1"-"4N I GOOD Q
S GOOD=REGPH?1"("3N1")"3N1"-"4N I GOOD Q
S GOOD=REGPH?1"("3N1")"3N1"."4N I GOOD Q
S GOOD=REGPH?3N1"."4N I GOOD Q
S GOOD=REGPH?3N1"."3N1"."4N I GOOD Q
S GOOD=REGPH?3N1"."3N1"."4N I GOOD Q
;NO PROPER PATTERN FOUND
K X
Q
VERIF ;EP - DO VERIFIED BY LINE
I $P($G(^AUPNPAT(DFN,0)),U,12)'="",$P($G(^AUPNPAT(DFN,0)),U,3)'="" D
. W !,"Last edited by: ",$P($G(^VA(200,$P($G(^AUPNPAT(DFN,0)),U,12),0)),U)," on ",$$FMTE^XLFDT($P($G(^AUPNPAT(DFN,0)),U,3),1)
Q
VERIF2 ;EP - DO VERIFIED BY LINE FOR INSURANCE SUMMARY SCREEN
I $P($G(CATREC),U,9)'="" D
. W !,"Last edited by: ",$P($G(^VA(200,$P(CATREC,U,9),0)),U)," on ",$$FMTE^XLFDT($P(CATREC,U,10),1)
Q
;RTNTAG - TAG IN AGINS TO CALL. SPECIFIC TO TYPE OF INSURER
;AGINS - STANDARD AGINS ARRAY
UPDTSEL(AGINS,COMPIEN,INSIEN) ;EP - UPDATE SELECTION
;S SEL=0 K AGINS ;S RTN=RTNTAG_"^AGINS(DFN)" D @RTN
D ^AGINS
Q:$G(COMPIEN)="" "" ;ERROR UNREPORTED BY GIMC 11/8/2005
;I $G(AGANS) D
;.;S AGSELECT=$G(AGINSNN(AGANS)) ;RESET BACK TO THE NOW UPDATED AGINSNN( ENTRY
;.;I AGSELECT="" S AGSELECT=$G(AGINSNN(AGANS,1)) ;MEDICARE
;.S AGSELECT=$G(AGINS(AGANS))
;E S AGSELECT=$$FINDNEW(.AGINSSN,COMPIEN) ;IF AGANS NOT DEFINED THEN THIS IS A NEW ENTRY
;E S AGSELECT=$$FINDNEW(.AGINS,COMPIEN)
S AGSELECT=$$FINDNEW(.AGINSNN,COMPIEN,INSIEN)
Q AGSELECT
;FIND NEW ENTRY IN AGINSSN BASED ON THE IEN VARIABLES
;FINDNEW(AGINSSN,COMPIEN) ;EP
;N REC,FOUND
;S REC="",FOUND=0,RETURN=""
;F S REC=$O(AGINSNN(REC)) Q:REC="" D Q:FOUND
;.I $P($G(AGINSNN(REC)),U,11)=COMPIEN S FOUND=1,RETURN=AGINSNN(REC)
;.;IF ENTRY IS MEDICARE THEN AGINSNN(1,1) OR AGINSNN(1,2) MAY EXIST
;Q RETURN
FINDNEW(AGINSNN,COMPIEN,INSIEN) ;EP - AG*7.1*1 IM18549 ORIGINALLY REPORTED AS
;A PROBLEM WITH PRIVATE INSURANCE. THIS COULD HAVE BEEN A PROBLEM WITH ANY OF THE INS. GUIVEN THE
;RIGHT CONDITIONS.
N REC,FOUND
S REC="AGINSNN(0)",FOUND=0,RETURN=""
F S REC=$Q(@REC) Q:REC="" D Q:FOUND
.I $P($G(@REC),U,4)'="G" D
..I $P($G(@REC),U,11)=COMPIEN,($P($G(@REC),U,2)=INSIEN) S FOUND=1,RETURN=@REC
.I $P($G(@REC),U,4)="G" D
..I $P($G(@REC),U,11)=COMPIEN,($P($G(@REC),U,2)=INSGLO_INSIEN) S FOUND=1,RETURN=@REC
.;I $G(INSIEN)'="" I $P($G(AGINSNN(REC)),U,2)'=INSIEN S FOUND=0, RETURN=""
Q RETURN
;DISPLAYS PROGRAMMER INFORMATION ON SCREEN. THIS IS FOR USE IN
;EDIT SCREEN ONLY AT THIS TIME
PROGVIEW(DUZ,SUBS) ;EP - DISPLAYS PROGRAMMER INFORMATION ON SCREEN
Q:'$D(^XUSEC("AGZPROG",DUZ))
S SUBS=$G(SUBS)
N AGPIECE,INDENT
W !,"|--------------------PROGRAMMER INFORMATION VIEW-------------------------------|"
W !,"|ED SCR RTN=",$G(ROUTID),?25,"DFN=",$G(DFN),?79,"|"
W !,"|ED CHK SCR=",$G(AG("PG")),?25,"AUPNPAT=",$G(AUPNPAT),?79,"|"
W !,"|"
S INDENT=0
I SUBS D
.F AGPIECE=1:1 Q:$P(SUBS,",",AGPIECE)="" D
..W ?INDENT,"SUB"_AGPIECE_"=",$P(SUBS,",",AGPIECE)
..S INDENT=INDENT+25
W ?79,"|"
W !,"|------------------------------------------------------------------------------|"
W !
Q
;CREATE AN "EDIT" LINE SHOWING USER HOW MANY SPACES TO ENTER FOR
;A FREE TEXT FIELD
NOTELINE(FIELDNUM,FILENUM,D0,LENGTH) ;EP -
;SAMPLE CALL
;W $$NOTELINE^AGUTILS(106,9000041.0101,1_","_5571_",",45)
N STRING,LABEL,DATALEN
S LABELLEN=$L($P($G(^DD(FILENUM,FIELDNUM,0)),U))
S DATALEN=$L($$GET1^DIQ(FILENUM,D0,FIELDNUM,"E"))
I DATALEN>19 Q "" ;DON'T EVEN TRY. IF ITS GRETAER THAN 19 THE "Replace" FUNCTION KICKS IN
I DATALEN'=0 S DATALEN=DATALEN+2 ;IF DATA PRESENT ADD 2 FOR "//"
S TOTINDEN=DATALEN+LABELLEN+2 ;ADD TWO FOR COLON AND SPACE
S $P(SPACER," ",TOTINDEN+1)=""
S $P(STRING,"-",LENGTH+1)=""
Q SPACER_"|"_STRING_"|"
;CENTER TEXT
CENTER(X) ;EP - CENTER TEXT
S CENTER=IOM/2
W ?CENTER-($L(X)/2),X
Q
;CHECK IF 1111 FIELD CONTAINS "NON-INDIAN"
ISNONIND(DFN) ;EP - CHECK IF 1111 FIELD CONTAINS "NON-INDIAN"
N PTR
S PTR=$P($G(^AUPNPAT(DFN,11)),U,11)
Q:PTR="" 1
Q $P($G(^AUTTBEN(PTR,0)),U)[("NON-INDIAN")
;ARE THERE ACTIVE POLICY MEMBERS ASSOCIATED WITH THIS POLICY HOLDER?
;ADDED TO STRENGTHEN CHANGES MADE BECAUSE OF
;BEGIN IM16640
ACTPOLME(PH) ;EP - ARE THERE ACTIVE POLICY MEMBERS ASSOCIATED WITH THIS POLICY HOLDER?
N PHPTR,POLMEM,PRVT0,PRVTINS,ACTIVE
S POLMEM=""
S ACTIVE=0
F S POLMEM=$O(^AUPNPRVT("C",PH,POLMEM)) Q:POLMEM=""!(ACTIVE) D
.S PRVTINS=""
.F S PRVTINS=$O(^AUPNPRVT("C",PH,POLMEM,PRVTINS)) Q:PRVTINS=""!(ACTIVE) D
..S PRVT11=$G(^AUPNPRVT(POLMEM,11,PRVTINS,0))
..S POLHOLD0=$G(^AUPN3PPH(PH,0))
..S MEM=$P(POLHOLD0,U,2)
..Q:MEM=POLMEM ;IGNORE POLICY HOLDER
..S EFFDATE=$P(PRVT11,U,6)
..S ENDDATE=$P(PRVT11,U,7)
..Q:'$$ISACTIVE(EFFDATE,ENDDATE)
..;IF NOT POLICY HOLDER AND POLICY ACTIVE THEN RETURN TRUE
..S ACTIVE=1
Q ACTIVE
ISACTIVE(EFFDT,ENDDT) ;EP - DETERMINE WHETHER THE POLICY IS ACTIVE AS OF TODAY
N OPENEND
I EFFDT="",(ENDDT="") Q 0 ;NO DATES CONSIDERED INACTIVE
S ENDDT=ENDDT ;TRUE IF END DATE IS AT COB OF END DATE - ANSWER FROM
;ADRIAN IS IT IS IN FORCE FOR ALL OF TODAY
S OPENEND=ENDDT=""
I OPENEND I DT=EFFDT!(DT>EFFDT) Q 1
I DT=EFFDT!(DT=ENDDT) Q 1
I DT>EFFDT&(DT<ENDDT) Q 1
Q 0
;RETURNS TRUE IF THERE ARE NO ACTIVE POLICY MEMBERS BESIDES POLICY HOLDER
NOPOLMEM(PH) ;EP - RETURNS TRUE IF THERE ARE NO ACTIVE POLICY MEMBERS BESIDES POLICY HOLDER
N PHPTR,POLMEM,PRVT0,PRVTINS,ACTIVE
S POLMEM=""
S ACTIVE=0
F S POLMEM=$O(^AUPNPRVT("C",PH,POLMEM)) Q:POLMEM=""!(ACTIVE) D
.S PRVTINS=""
.F S PRVTINS=$O(^AUPNPRVT("C",PH,POLMEM,PRVTINS)) Q:PRVTINS=""!(ACTIVE) D
..S PRVT11=$G(^AUPNPRVT(POLMEM,11,PRVTINS,0))
..S POLHOLD0=$G(^AUPN3PPH(PH,0))
..S MEM=$P(POLHOLD0,U,2)
..Q:MEM=POLMEM ;IGNORE POLICY HOLDER
..S EFFDATE=$P(PRVT11,U,6)
..S ENDDATE=$P(PRVT11,U,7)
..Q:'$$ISACTIVE(EFFDATE,ENDDATE)
..;IF NOT POLICY HOLDER AND POLICY ACTIVE THEN RETURN TRUE
..S ACTIVE=1
Q 'ACTIVE
;RETURNS THE "DATE ESTABLISHED" OR "DATE OF LAST REG. UPDATE" FOR DISPLAY ON EDIT SCREENS
DTEST(AGDFN) ;EP - RETURNS THE "DATE ESTABLISHED" OR "DATE OF LAST REG. UPDATE" FOR DISPLAY
Q:'AGDFN ""
S Y=$P($G(^AUPNPAT(AGDFN,0)),U,3) ;DATE OF LAST REG. UPDATE
D DD^%DT
Q:Y'="" "(upd:"_Y_")"
S Y=$P($G(^AUPNPAT(AGDFN,0)),U,2)
D DD^%DT
Q:Y'="" "(est:"_Y_")"
Q "(est:unknown)"
;
;FIND SINGLE PATIENTS WITH 'SPOUSES EMPLOYER"
SPOUSE ;EP
K EMPL S EMP="" F S EMP=$O(^AUPNPAT("AG",EMP)) Q:'EMP D
.S DFN="" F S DFN=$O(^AUPNPAT("AG",EMP,DFN)) Q:'DFN D
..Q:$P($G(^DPT(DFN,.35)),U) Q:$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3)
..S MS=$$GET1^DIQ(2,DFN_",",.05,"E") Q:MS="MARRIED"
..S SPEMP=$$GET1^DIQ(9000001,DFN_",",.22,"E") S HRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
..S EMPL(SPEMP)=$G(EMPL(SPEMP))+1 S EMPL(SPEMP,HRN)=""
Q
;NEW SUBROUTINE IHS/SD/TPF AG*7.1*1 ITEM 18
;IS PATIENT A MINOR <18
ISMINOR(DFN) ;EP - CHECK IF PATIENT IS A MINOR <18
Q:'DFN 1
S D0=DFN
X $P($G(^DD(2,.033,0)),U,5,299) ;GET AGE
Q X<$G(AGOPT("AGE OF MINOR")) ;HARD CODED PER SANDRI LAHI
;BEGIN NEW CODE IHS/SD/TPF 5/2/2006 AG*7.1*2 PAGE 12 ITEM 3
AGE(AGPATDFN) ;EP - RETURN AGE
S D0=DFN X $P($G(^DD(2,.033,0)),U,5,299)
Q X
TESTAPI ;EP -
S X=$$F111^AGAPIPAT(5571,"TEST NEW ADDRESS")
Q
;END NEW CODE
UPPER(STR) ;EP - CHANGE LOWER TO UPPER
Q $TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;SUBROUTINE COPIED FROM AGED51 (WRITTEN BY GEORGE HUGGINS)
USED(DFN,AGINSPTR,AGP,AGDA,AGMCDDA) ;EP - Is this Eligibility date record used in a 3P Bill or Claim?
;;@;*7
;;@;IORVON
;;WARNING :
;;@;IORVOFF
;; You have selected an Eligibility Date Record that is used
;; by
;;@;AGBILL
;; in 3PB. Modifying or deleting this Eligibility
;; Date Record will degrade the integrity of your database
;; and could adversely effect revenue recovery through 3PB!!
;;###
;
NEW AGBILL,AGDUZ2,AGUSED,AG13,Y
S (AGBILL,AGDUZ2,AGUSED)=0
;Check all Pt's bills.
F S AGDUZ2=$O(^ABMDBILL(AGDUZ2)) Q:'AGDUZ2 D Q:AGUSED
. F S AGBILL=$O(^ABMDBILL(AGDUZ2,"D",DFN,AGBILL)) Q:'AGBILL D Q:AGUSED
.. I $P(^ABMDBILL(AGDUZ2,AGBILL,0),U,4)="X" Q ;Cancelled.
.. S AG13=0
.. F S AG13=$O(^ABMDBILL(AGDUZ2,AGBILL,13,AG13)) Q:'AG13 D Q:AGUSED
... ;Same multiple?
... ;Q:'($P(^ABMDBILL(AGDUZ2,AGBILL,13,AG13,0),U,AGP)=AGDA)
... Q:'($P($G(^ABMDBILL(AGDUZ2,AGBILL,13,AG13,0)),U,AGP)=AGDA) ;IM21932 ZERO NODE MISSING FOR INSURER
... ;If MCD, same IEN?
... I AGP=7,'($P(^ABMDBILL(AGDUZ2,AGBILL,13,AG13,0),U,6)=AGMCDDA) Q
... S AGUSED=$P(^ABMDBILL(AGDUZ2,AGBILL,0),U)_" ("_$P(^DIC(4,AGDUZ2,0),U)_")" ; Bill number (Site).
...Q
..Q
.Q
I AGUSED Q "Bill # "_AGUSED
;
S (AGBILL,AGDUZ2,AGUSED)=0
;Check all Pt's claims.
F S AGDUZ2=$O(^ABMDCLM(AGDUZ2)) Q:'AGDUZ2 D Q:AGUSED
. F S AGBILL=$O(^ABMDCLM(AGDUZ2,"B",DFN,AGBILL)) Q:'AGBILL D Q:AGUSED
.. S AG13=0
.. F S AG13=$O(^ABMDCLM(AGDUZ2,AGBILL,13,AG13)) Q:'AG13 D Q:AGUSED
... ;Same multiple?
... ;Q:'($P(^ABMDCLM(AGDUZ2,AGBILL,13,AG13,0),U,AGP)=AGDA)
... Q:'($P($G(^ABMDCLM(AGDUZ2,AGBILL,13,AG13,0)),U,AGP)=AGDA) ;IM21932 ZERO NODE MISSING FOR INSURER
... ;If MCD, same IEN?
... I AGP=7,'($P(^ABMDCLM(AGDUZ2,AGBILL,13,AG13,0),U,6)=AGMCDDA) Q
... S AGUSED=AGBILL_" ("_$P(^DIC(4,AGDUZ2,0),U)_")" ;Claim number (Site).
...Q
..Q
.Q
I AGUSED Q "Claim # "_AGUSED
Q ""
;
; MEDICARE MULTIPLE (NJ6,0), [0;4]
; RAILROAD MULTIPLE (NJ6,0), [0;5]
; MEDICAID ELIG POINTER (*P9000004'), [0;6]
; MEDICAID MULTIPLE (NJ4,0), [0;7]
; PRIVATE INSURANCE MULTIPLE (NJ6,0), [0;8]
AGUTILS ;IHS/ASDS/TPF - PAT REG UTILITY ROUTINE ; 3/25/2004 8:25:20 AM
+1 ;;7.1;PATIENT REGISTRATION;**1,2,4,5**;JAN 31, 2007
+2 ;
+3 QUIT
UPDTEMAL(PATDFN) ;EP - UPDATE HISTORICAL EMAIL ADDRESS
+1 NEW ADDREC
+2 KILL DIE,DIC,DR,DA,DIR
+3 SET DA(1)=PATDFN
+4 SET DIC="^AUPNPAT("_DA(1)_",82,"
+5 SET DIC(0)="L"
+6 SET X=""""_DT_""""
+7 DO ^DIC
+8 IF Y<0
Begin DoDot:1
+9 WRITE !!,"HISTORICAL EMAIL ADDRESS COULD NOT BE UPDATED!!"
+10 KILL DIE,DIC,DR,DA,DIR
+11 SET DIR(0)="E"
+12 DO ^DIR
End DoDot:1
QUIT
+13 SET ADDREC=+Y
+14 NEW AGEMAIL
+15 SET AGEMAIL=$$GET1^DIQ(9000001,PATDFN_",",1802)
+16 KILL DIE,DIC,DR,DA,DIR
+17 SET DA=ADDREC
+18 SET DA(1)=PATDFN
+19 SET DIE="^AUPNPAT("_DA(1)_",82,"
+20 SET DR=".02///^S X=AGEMAIL;"
+21 DO ^DIE
+22 KILL DIE,DIC,DR,DA,DIR
+23 ;
+24 QUIT
+25 ;FORCE MEANS USE //// TO FORCE THE DATA INTO THE NEW FIELDS
+26 ;THIS IS USED ONLY ON THE POST INSTALL TO ACCEPT BAD DATA ENTERED BY SITES
+27 ;USUALLY INTO THE CITY FIELD. iF FORCE="F" THEN FORCE
UPDTHADD(PATDFN,FORCE) ;EP - UPDATE HISTORICAL ADDRESS FROM FILE #2 ADRESS FIELDS
+1 SET FORCE=$GET(FORCE)
+2 ;F MEANS CALLED FROM POST INSTALL. QUIT IF THEY ALREADY HAVE AN HIST. ADDRESS. TAKES CARE OF BETA SITES
IF FORCE="F"
IF $ORDER(^AUPNPAT(PATDFN,83,0))
QUIT
+3 NEW ADDREC
+4 KILL DIE,DIC,DR,DA,DIR
+5 SET DA(1)=PATDFN
+6 SET DIC="^AUPNPAT("_DA(1)_",83,"
+7 SET DIC(0)="L"
+8 SET X=""""_DT_""""
+9 DO ^DIC
+10 IF Y<0
Begin DoDot:1
+11 WRITE !!,"HISTORICAL ADDRESS COULD NOT BE UPDATED!!"
+12 KILL DIE,DIC,DR,DA,DIR
+13 SET DIR(0)="E"
+14 DO ^DIR
End DoDot:1
QUIT
+15 SET ADDREC=+Y
+16 ;
+17 ;get the current ADDRESS VALUES
+18 NEW AGSTR1,STREET2,STREET3,CITY,STATE,ZIP,HPHONE
+19 SET AGSTR1=$$GET1^DIQ(2,PATDFN_",",.111)
+20 SET AGSTR2=$$GET1^DIQ(2,PATDFN_",",.112)
+21 SET AGSTR3=$$GET1^DIQ(2,PATDFN_",",.113)
+22 SET AGCITY=$$GET1^DIQ(2,PATDFN_",",.114)
+23 SET AGSTATE=$$GET1^DIQ(2,PATDFN_",",.115)
+24 IF $GET(AGSTATE)'=""
IF AGSTATE'=+AGSTATE
SET AGSTATE=$ORDER(^DIC(5,"B",AGSTATE,""))
+25 SET AGZIP=$$GET1^DIQ(2,PATDFN_",",.116)
+26 SET AGHPHONE=$$GET1^DIQ(2,PATDFN_",",.131)
+27 ;
+28 KILL DIE,DIC,DR,DA,DIR
+29 SET DA=ADDREC
+30 SET DA(1)=PATDFN
+31 SET DIE="^AUPNPAT("_DA(1)_",83,"
+32 ;I FORCE="F" S DR=".02////AGSTR1;"
+33 IF FORCE="F"
SET DR=".02////"_AGSTR1_";"
+34 IF '$TEST
SET DR=".02///^S X=AGSTR1;"
+35 ;I FORCE="F" S DR=DR_".03////AGSTR2;"
+36 IF FORCE="F"
SET DR=DR_".03////"_AGSTR2_";"
+37 IF '$TEST
SET DR=DR_".03///^S X=AGSTR2;"
+38 ;I FORCE="F" S DR=DR_".04////AGSTR3;"
+39 IF FORCE="F"
SET DR=DR_".04////"_AGSTR3_";"
+40 IF '$TEST
SET DR=DR_".04///^S X=AGSTR3;"
+41 ;I FORCE="F" S DR=DR_".05////AGCITY;"
+42 IF FORCE="F"
SET DR=DR_".05////"_AGCITY_";"
+43 IF '$TEST
SET DR=DR_".05///^S X=AGCITY;"
+44 ;I FORCE="F" S DR=DR_".06////AGSTATE;"
+45 IF FORCE="F"
SET DR=DR_".06////"_AGSTATE_";"
+46 IF '$TEST
SET DR=DR_".06///^S X=AGSTATE;"
+47 ;I FORCE="F" S DR=DR_".07////AGZIP;"
+48 IF FORCE="F"
SET DR=DR_".07////"_AGZIP_";"
+49 IF '$TEST
SET DR=DR_".07///^S X=AGZIP;"
+50 ;I FORCE="F" S DR=DR_".08////AGHPHONE"
+51 IF FORCE="F"
SET DR=DR_".08////"_AGHPHONE_""
+52 IF '$TEST
SET DR=DR_".08///^S X=AGHPHONE"
+53 DO ^DIE
+54 KILL DIE,DIC,DR,DA,DIR
+55 QUIT
+56 ;
+57 ;SEND ALERT MESSAGE
ALERTMSG(XMDUZ,XMY,XMSUB,XMTEXT) ;EP
+1 DO ^XMD
+2 IF $GET(XMMG)'=""
WRITE !,XMMG
HANG 2
+3 QUIT
WRAP(X,DIWL,DIWF) ;EP - WRAP TEXT #DEV DISPLAY
+1 KILL ^UTILITY($JOB,"W")
+2 DO ^DIWP
+3 DO ^DIWW
+4 QUIT
+5 ;IS MANDATORY SEQUENCING TURNED ON?
+6 ;FIELD ^AGFAC(D0,21)= (#2101) MANDATORY SEQUENCING IN REGISTRATION PARAMETER FILE
SEQMAN(FAC) ;EP - IS MANDATORY SEQUENCING TURNED ON?
+1 QUIT $PIECE($GET(^AGFAC(FAC,21)),U)
+2 ;DOES THE PATIENT HAVE A SEQUENCE SET UP?
PATSEQ(DFN) ;EP
+1 QUIT $DATA(^AUPNICP("C",DFN))
+2 ;DOES THE USER NEED TO SEQUENCE?
NEEDTOSQ(DFN,FAC) ;EP - DOES THE USER NEED TO SEQUENCE?
+1 NEW TRUE
+2 SET TRUE=$$SEQMAN(FAC)&('$$PATSEQ(DFN))
+3 QUIT TRUE
+4 ;INPUT TRANSFORM FOR E-MAIL FIELDS. CHECK FOR VALID E-MAIL ADDRESS
EMAIL ;EP - CHECK FOR VALID E-MAIL ADDRESS
+1 NEW HOST,NAME
+2 ;CHECK FOR .EXT SHOULD BE 2 OR THREE CHARS AT THE END AFTER "."
+3 SET EXTENT=$PIECE(X,".",$LENGTH(X,"."))
+4 ;MINIMUM IS X@X
IF $LENGTH(X)<3
KILL X
QUIT
+5 ;TOTAL LENGTH CANNOT EXCEED 65
IF $LENGTH(X)>65
KILL X
QUIT
+6 ;GENERAL PATTERN OF 'XXXX@XXXX'
IF X'[("@")
KILL X
QUIT
+7 ;MUST HAVE JUST ONE "@"
IF $LENGTH(X,"@")'=2
KILL X
QUIT
+8 SET HOST=$PIECE(X,"@",2)
+9 SET NAME=$PIECE(X,"@")
+10 ;NAME MUST END IN ALPHA OR NUMERIC
+11 IF '($EXTRACT(NAME,$LENGTH(NAME))?1A)&'($EXTRACT(NAME,$LENGTH(NAME))?1N)
KILL X
QUIT
+12 ;HOST MUST BEGIN WITH ALPHA OR NUMERIC
+13 IF '($EXTRACT(HOST)?1A)&'($EXTRACT(HOST)?1N)
KILL X
QUIT
+14 IF HOST'[(".")
KILL X
QUIT
+15 ;THE FOLLOWING CHARACTER PAIRS ARE NOT ALLOWED
+16 IF X[(".-")
KILL X
QUIT
+17 IF X[("-.")
KILL X
QUIT
+18 IF X[("-.")
KILL X
QUIT
+19 IF X[("--")
KILL X
QUIT
+20 IF X[("..")
KILL X
QUIT
+21 IF X[("._")
KILL X
QUIT
+22 IF X[("-_")
KILL X
QUIT
+23 IF X[("_.")
KILL X
QUIT
+24 IF X[("_-")
KILL X
QUIT
+25 IF X[("__")
KILL X
QUIT
+26 ;THE FOLLOWING CHARACTERS ARE NOT ALLOWED
+27 IF X[(",")
KILL X
QUIT
+28 IF X[(";")
KILL X
QUIT
+29 IF X[(":")
KILL X
QUIT
+30 IF X[("(")
KILL X
QUIT
+31 IF X[(")")
KILL X
QUIT
+32 IF X[("=")
KILL X
QUIT
+33 IF X[("+")
KILL X
QUIT
+34 IF X[("!")
KILL X
QUIT
+35 IF X[("<")
KILL X
QUIT
+36 IF X[(">")
KILL X
QUIT
+37 IF X[("?")
KILL X
QUIT
+38 IF X[("/")
KILL X
QUIT
+39 IF X[("\")
KILL X
QUIT
+40 QUIT
VALPHONE ;EP - CHECK FOR VALID PHONE ENTRY
+1 NEW GOOD,EXT
+2 SET GOOD=0
+3 SET REGPH=X
+4 IF REGPH[("EXT")
SET REGPH=$TRANSLATE($PIECE(REGPH,"EXT")," ")
IF $TRANSLATE($PIECE(X,"EXT",2)," ")=""
SET X=REGPH
+5 IF REGPH[("ext")
SET REGPH=$TRANSLATE($PIECE(REGPH,"ext")," ")
IF $TRANSLATE($PIECE(X,"ext",2)," ")=""
SET X=REGPH
+6 ;extension only
SET GOOD=REGPH?4N
IF GOOD
QUIT
+7 SET GOOD=REGPH?3N1"-"4N
IF GOOD
QUIT
+8 SET GOOD=REGPH?3N1"-"3N1"-"4N
IF GOOD
QUIT
+9 SET GOOD=REGPH?1"("3N1")"3N1"-"4N
IF GOOD
QUIT
+10 SET GOOD=REGPH?1"("3N1")"3N1"."4N
IF GOOD
QUIT
+11 SET GOOD=REGPH?3N1"."4N
IF GOOD
QUIT
+12 SET GOOD=REGPH?3N1"."3N1"."4N
IF GOOD
QUIT
+13 SET GOOD=REGPH?3N1"."3N1"."4N
IF GOOD
QUIT
+14 ;NO PROPER PATTERN FOUND
+15 KILL X
+16 QUIT
VERIF ;EP - DO VERIFIED BY LINE
+1 IF $PIECE($GET(^AUPNPAT(DFN,0)),U,12)'=""
IF $PIECE($GET(^AUPNPAT(DFN,0)),U,3)'=""
Begin DoDot:1
+2 WRITE !,"Last edited by: ",$PIECE($GET(^VA(200,$PIECE($GET(^AUPNPAT(DFN,0)),U,12),0)),U)," on ",$$FMTE^XLFDT($PIECE($GET(^AUPNPAT(DFN,0)),U,3),1)
End DoDot:1
+3 QUIT
VERIF2 ;EP - DO VERIFIED BY LINE FOR INSURANCE SUMMARY SCREEN
+1 IF $PIECE($GET(CATREC),U,9)'=""
Begin DoDot:1
+2 WRITE !,"Last edited by: ",$PIECE($GET(^VA(200,$PIECE(CATREC,U,9),0)),U)," on ",$$FMTE^XLFDT($PIECE(CATREC,U,10),1)
End DoDot:1
+3 QUIT
+4 ;RTNTAG - TAG IN AGINS TO CALL. SPECIFIC TO TYPE OF INSURER
+5 ;AGINS - STANDARD AGINS ARRAY
UPDTSEL(AGINS,COMPIEN,INSIEN) ;EP - UPDATE SELECTION
+1 ;S SEL=0 K AGINS ;S RTN=RTNTAG_"^AGINS(DFN)" D @RTN
+2 DO ^AGINS
+3 ;ERROR UNREPORTED BY GIMC 11/8/2005
IF $GET(COMPIEN)=""
QUIT ""
+4 ;I $G(AGANS) D
+5 ;.;S AGSELECT=$G(AGINSNN(AGANS)) ;RESET BACK TO THE NOW UPDATED AGINSNN( ENTRY
+6 ;.;I AGSELECT="" S AGSELECT=$G(AGINSNN(AGANS,1)) ;MEDICARE
+7 ;.S AGSELECT=$G(AGINS(AGANS))
+8 ;E S AGSELECT=$$FINDNEW(.AGINSSN,COMPIEN) ;IF AGANS NOT DEFINED THEN THIS IS A NEW ENTRY
+9 ;E S AGSELECT=$$FINDNEW(.AGINS,COMPIEN)
+10 SET AGSELECT=$$FINDNEW(.AGINSNN,COMPIEN,INSIEN)
+11 QUIT AGSELECT
+12 ;FIND NEW ENTRY IN AGINSSN BASED ON THE IEN VARIABLES
+13 ;FINDNEW(AGINSSN,COMPIEN) ;EP
+14 ;N REC,FOUND
+15 ;S REC="",FOUND=0,RETURN=""
+16 ;F S REC=$O(AGINSNN(REC)) Q:REC="" D Q:FOUND
+17 ;.I $P($G(AGINSNN(REC)),U,11)=COMPIEN S FOUND=1,RETURN=AGINSNN(REC)
+18 ;.;IF ENTRY IS MEDICARE THEN AGINSNN(1,1) OR AGINSNN(1,2) MAY EXIST
+19 ;Q RETURN
FINDNEW(AGINSNN,COMPIEN,INSIEN) ;EP - AG*7.1*1 IM18549 ORIGINALLY REPORTED AS
+1 ;A PROBLEM WITH PRIVATE INSURANCE. THIS COULD HAVE BEEN A PROBLEM WITH ANY OF THE INS. GUIVEN THE
+2 ;RIGHT CONDITIONS.
+3 NEW REC,FOUND
+4 SET REC="AGINSNN(0)"
SET FOUND=0
SET RETURN=""
+5 FOR
SET REC=$QUERY(@REC)
IF REC=""
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(@REC),U,4)'="G"
Begin DoDot:2
+7 IF $PIECE($GET(@REC),U,11)=COMPIEN
IF ($PIECE($GET(@REC),U,2)=INSIEN)
SET FOUND=1
SET RETURN=@REC
End DoDot:2
+8 IF $PIECE($GET(@REC),U,4)="G"
Begin DoDot:2
+9 IF $PIECE($GET(@REC),U,11)=COMPIEN
IF ($PIECE($GET(@REC),U,2)=INSGLO_INSIEN)
SET FOUND=1
SET RETURN=@REC
End DoDot:2
+10 ;I $G(INSIEN)'="" I $P($G(AGINSNN(REC)),U,2)'=INSIEN S FOUND=0, RETURN=""
End DoDot:1
IF FOUND
QUIT
+11 QUIT RETURN
+12 ;DISPLAYS PROGRAMMER INFORMATION ON SCREEN. THIS IS FOR USE IN
+13 ;EDIT SCREEN ONLY AT THIS TIME
PROGVIEW(DUZ,SUBS) ;EP - DISPLAYS PROGRAMMER INFORMATION ON SCREEN
+1 IF '$DATA(^XUSEC("AGZPROG",DUZ))
QUIT
+2 SET SUBS=$GET(SUBS)
+3 NEW AGPIECE,INDENT
+4 WRITE !,"|--------------------PROGRAMMER INFORMATION VIEW-------------------------------|"
+5 WRITE !,"|ED SCR RTN=",$GET(ROUTID),?25,"DFN=",$GET(DFN),?79,"|"
+6 WRITE !,"|ED CHK SCR=",$GET(AG("PG")),?25,"AUPNPAT=",$GET(AUPNPAT),?79,"|"
+7 WRITE !,"|"
+8 SET INDENT=0
+9 IF SUBS
Begin DoDot:1
+10 FOR AGPIECE=1:1
IF $PIECE(SUBS,",",AGPIECE)=""
QUIT
Begin DoDot:2
+11 WRITE ?INDENT,"SUB"_AGPIECE_"=",$PIECE(SUBS,",",AGPIECE)
+12 SET INDENT=INDENT+25
End DoDot:2
End DoDot:1
+13 WRITE ?79,"|"
+14 WRITE !,"|------------------------------------------------------------------------------|"
+15 WRITE !
+16 QUIT
+17 ;CREATE AN "EDIT" LINE SHOWING USER HOW MANY SPACES TO ENTER FOR
+18 ;A FREE TEXT FIELD
NOTELINE(FIELDNUM,FILENUM,D0,LENGTH) ;EP -
+1 ;SAMPLE CALL
+2 ;W $$NOTELINE^AGUTILS(106,9000041.0101,1_","_5571_",",45)
+3 NEW STRING,LABEL,DATALEN
+4 SET LABELLEN=$LENGTH($PIECE($GET(^DD(FILENUM,FIELDNUM,0)),U))
+5 SET DATALEN=$LENGTH($$GET1^DIQ(FILENUM,D0,FIELDNUM,"E"))
+6 ;DON'T EVEN TRY. IF ITS GRETAER THAN 19 THE "Replace" FUNCTION KICKS IN
IF DATALEN>19
QUIT ""
+7 ;IF DATA PRESENT ADD 2 FOR "//"
IF DATALEN'=0
SET DATALEN=DATALEN+2
+8 ;ADD TWO FOR COLON AND SPACE
SET TOTINDEN=DATALEN+LABELLEN+2
+9 SET $PIECE(SPACER," ",TOTINDEN+1)=""
+10 SET $PIECE(STRING,"-",LENGTH+1)=""
+11 QUIT SPACER_"|"_STRING_"|"
+12 ;CENTER TEXT
CENTER(X) ;EP - CENTER TEXT
+1 SET CENTER=IOM/2
+2 WRITE ?CENTER-($LENGTH(X)/2),X
+3 QUIT
+4 ;CHECK IF 1111 FIELD CONTAINS "NON-INDIAN"
ISNONIND(DFN) ;EP - CHECK IF 1111 FIELD CONTAINS "NON-INDIAN"
+1 NEW PTR
+2 SET PTR=$PIECE($GET(^AUPNPAT(DFN,11)),U,11)
+3 IF PTR=""
QUIT 1
+4 QUIT $PIECE($GET(^AUTTBEN(PTR,0)),U)[("NON-INDIAN")
+5 ;ARE THERE ACTIVE POLICY MEMBERS ASSOCIATED WITH THIS POLICY HOLDER?
+6 ;ADDED TO STRENGTHEN CHANGES MADE BECAUSE OF
+7 ;BEGIN IM16640
ACTPOLME(PH) ;EP - ARE THERE ACTIVE POLICY MEMBERS ASSOCIATED WITH THIS POLICY HOLDER?
+1 NEW PHPTR,POLMEM,PRVT0,PRVTINS,ACTIVE
+2 SET POLMEM=""
+3 SET ACTIVE=0
+4 FOR
SET POLMEM=$ORDER(^AUPNPRVT("C",PH,POLMEM))
IF POLMEM=""!(ACTIVE)
QUIT
Begin DoDot:1
+5 SET PRVTINS=""
+6 FOR
SET PRVTINS=$ORDER(^AUPNPRVT("C",PH,POLMEM,PRVTINS))
IF PRVTINS=""!(ACTIVE)
QUIT
Begin DoDot:2
+7 SET PRVT11=$GET(^AUPNPRVT(POLMEM,11,PRVTINS,0))
+8 SET POLHOLD0=$GET(^AUPN3PPH(PH,0))
+9 SET MEM=$PIECE(POLHOLD0,U,2)
+10 ;IGNORE POLICY HOLDER
IF MEM=POLMEM
QUIT
+11 SET EFFDATE=$PIECE(PRVT11,U,6)
+12 SET ENDDATE=$PIECE(PRVT11,U,7)
+13 IF '$$ISACTIVE(EFFDATE,ENDDATE)
QUIT
+14 ;IF NOT POLICY HOLDER AND POLICY ACTIVE THEN RETURN TRUE
+15 SET ACTIVE=1
End DoDot:2
End DoDot:1
+16 QUIT ACTIVE
ISACTIVE(EFFDT,ENDDT) ;EP - DETERMINE WHETHER THE POLICY IS ACTIVE AS OF TODAY
+1 NEW OPENEND
+2 ;NO DATES CONSIDERED INACTIVE
IF EFFDT=""
IF (ENDDT="")
QUIT 0
+3 ;TRUE IF END DATE IS AT COB OF END DATE - ANSWER FROM
SET ENDDT=ENDDT
+4 ;ADRIAN IS IT IS IN FORCE FOR ALL OF TODAY
+5 SET OPENEND=ENDDT=""
+6 IF OPENEND
IF DT=EFFDT!(DT>EFFDT)
QUIT 1
+7 IF DT=EFFDT!(DT=ENDDT)
QUIT 1
+8 IF DT>EFFDT&(DT<ENDDT)
QUIT 1
+9 QUIT 0
+10 ;RETURNS TRUE IF THERE ARE NO ACTIVE POLICY MEMBERS BESIDES POLICY HOLDER
NOPOLMEM(PH) ;EP - RETURNS TRUE IF THERE ARE NO ACTIVE POLICY MEMBERS BESIDES POLICY HOLDER
+1 NEW PHPTR,POLMEM,PRVT0,PRVTINS,ACTIVE
+2 SET POLMEM=""
+3 SET ACTIVE=0
+4 FOR
SET POLMEM=$ORDER(^AUPNPRVT("C",PH,POLMEM))
IF POLMEM=""!(ACTIVE)
QUIT
Begin DoDot:1
+5 SET PRVTINS=""
+6 FOR
SET PRVTINS=$ORDER(^AUPNPRVT("C",PH,POLMEM,PRVTINS))
IF PRVTINS=""!(ACTIVE)
QUIT
Begin DoDot:2
+7 SET PRVT11=$GET(^AUPNPRVT(POLMEM,11,PRVTINS,0))
+8 SET POLHOLD0=$GET(^AUPN3PPH(PH,0))
+9 SET MEM=$PIECE(POLHOLD0,U,2)
+10 ;IGNORE POLICY HOLDER
IF MEM=POLMEM
QUIT
+11 SET EFFDATE=$PIECE(PRVT11,U,6)
+12 SET ENDDATE=$PIECE(PRVT11,U,7)
+13 IF '$$ISACTIVE(EFFDATE,ENDDATE)
QUIT
+14 ;IF NOT POLICY HOLDER AND POLICY ACTIVE THEN RETURN TRUE
+15 SET ACTIVE=1
End DoDot:2
End DoDot:1
+16 QUIT 'ACTIVE
+17 ;RETURNS THE "DATE ESTABLISHED" OR "DATE OF LAST REG. UPDATE" FOR DISPLAY ON EDIT SCREENS
DTEST(AGDFN) ;EP - RETURNS THE "DATE ESTABLISHED" OR "DATE OF LAST REG. UPDATE" FOR DISPLAY
+1 IF 'AGDFN
QUIT ""
+2 ;DATE OF LAST REG. UPDATE
SET Y=$PIECE($GET(^AUPNPAT(AGDFN,0)),U,3)
+3 DO DD^%DT
+4 IF Y'=""
QUIT "(upd:"_Y_")"
+5 SET Y=$PIECE($GET(^AUPNPAT(AGDFN,0)),U,2)
+6 DO DD^%DT
+7 IF Y'=""
QUIT "(est:"_Y_")"
+8 QUIT "(est:unknown)"
+9 ;
+10 ;FIND SINGLE PATIENTS WITH 'SPOUSES EMPLOYER"
SPOUSE ;EP
+1 KILL EMPL
SET EMP=""
FOR
SET EMP=$ORDER(^AUPNPAT("AG",EMP))
IF 'EMP
QUIT
Begin DoDot:1
+2 SET DFN=""
FOR
SET DFN=$ORDER(^AUPNPAT("AG",EMP,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+3 IF $PIECE($GET(^DPT(DFN,.35)),U)
QUIT
IF $PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,3)
QUIT
+4 SET MS=$$GET1^DIQ(2,DFN_",",.05,"E")
IF MS="MARRIED"
QUIT
+5 SET SPEMP=$$GET1^DIQ(9000001,DFN_",",.22,"E")
SET HRN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+6 SET EMPL(SPEMP)=$GET(EMPL(SPEMP))+1
SET EMPL(SPEMP,HRN)=""
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;NEW SUBROUTINE IHS/SD/TPF AG*7.1*1 ITEM 18
+9 ;IS PATIENT A MINOR <18
ISMINOR(DFN) ;EP - CHECK IF PATIENT IS A MINOR <18
+1 IF 'DFN
QUIT 1
+2 SET D0=DFN
+3 ;GET AGE
XECUTE $PIECE($GET(^DD(2,.033,0)),U,5,299)
+4 ;HARD CODED PER SANDRI LAHI
QUIT X<$GET(AGOPT("AGE OF MINOR"))
+5 ;BEGIN NEW CODE IHS/SD/TPF 5/2/2006 AG*7.1*2 PAGE 12 ITEM 3
AGE(AGPATDFN) ;EP - RETURN AGE
+1 SET D0=DFN
XECUTE $PIECE($GET(^DD(2,.033,0)),U,5,299)
+2 QUIT X
TESTAPI ;EP -
+1 SET X=$$F111^AGAPIPAT(5571,"TEST NEW ADDRESS")
+2 QUIT
+3 ;END NEW CODE
UPPER(STR) ;EP - CHANGE LOWER TO UPPER
+1 QUIT $TRANSLATE(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;SUBROUTINE COPIED FROM AGED51 (WRITTEN BY GEORGE HUGGINS)
USED(DFN,AGINSPTR,AGP,AGDA,AGMCDDA) ;EP - Is this Eligibility date record used in a 3P Bill or Claim?
+1 ;;@;*7
+2 ;;@;IORVON
+3 ;;WARNING :
+4 ;;@;IORVOFF
+5 ;; You have selected an Eligibility Date Record that is used
+6 ;; by
+7 ;;@;AGBILL
+8 ;; in 3PB. Modifying or deleting this Eligibility
+9 ;; Date Record will degrade the integrity of your database
+10 ;; and could adversely effect revenue recovery through 3PB!!
+11 ;;###
+12 ;
+13 NEW AGBILL,AGDUZ2,AGUSED,AG13,Y
+14 SET (AGBILL,AGDUZ2,AGUSED)=0
+15 ;Check all Pt's bills.
+16 FOR
SET AGDUZ2=$ORDER(^ABMDBILL(AGDUZ2))
IF 'AGDUZ2
QUIT
Begin DoDot:1
+17 FOR
SET AGBILL=$ORDER(^ABMDBILL(AGDUZ2,"D",DFN,AGBILL))
IF 'AGBILL
QUIT
Begin DoDot:2
+18 ;Cancelled.
IF $PIECE(^ABMDBILL(AGDUZ2,AGBILL,0),U,4)="X"
QUIT
+19 SET AG13=0
+20 FOR
SET AG13=$ORDER(^ABMDBILL(AGDUZ2,AGBILL,13,AG13))
IF 'AG13
QUIT
Begin DoDot:3
+21 ;Same multiple?
+22 ;Q:'($P(^ABMDBILL(AGDUZ2,AGBILL,13,AG13,0),U,AGP)=AGDA)
+23 ;IM21932 ZERO NODE MISSING FOR INSURER
IF '($PIECE($GET(^ABMDBILL(AGDUZ2,AGBILL,13,AG13,0)),U,AGP)=AGDA)
QUIT
+24 ;If MCD, same IEN?
+25 IF AGP=7
IF '($PIECE(^ABMDBILL(AGDUZ2,AGBILL,13,AG13,0),U,6)=AGMCDDA)
QUIT
+26 ; Bill number (Site).
SET AGUSED=$PIECE(^ABMDBILL(AGDUZ2,AGBILL,0),U)_" ("_$PIECE(^DIC(4,AGDUZ2,0),U)_")"
+27 QUIT
End DoDot:3
IF AGUSED
QUIT
+28 QUIT
End DoDot:2
IF AGUSED
QUIT
+29 QUIT
End DoDot:1
IF AGUSED
QUIT
+30 IF AGUSED
QUIT "Bill # "_AGUSED
+31 ;
+32 SET (AGBILL,AGDUZ2,AGUSED)=0
+33 ;Check all Pt's claims.
+34 FOR
SET AGDUZ2=$ORDER(^ABMDCLM(AGDUZ2))
IF 'AGDUZ2
QUIT
Begin DoDot:1
+35 FOR
SET AGBILL=$ORDER(^ABMDCLM(AGDUZ2,"B",DFN,AGBILL))
IF 'AGBILL
QUIT
Begin DoDot:2
+36 SET AG13=0
+37 FOR
SET AG13=$ORDER(^ABMDCLM(AGDUZ2,AGBILL,13,AG13))
IF 'AG13
QUIT
Begin DoDot:3
+38 ;Same multiple?
+39 ;Q:'($P(^ABMDCLM(AGDUZ2,AGBILL,13,AG13,0),U,AGP)=AGDA)
+40 ;IM21932 ZERO NODE MISSING FOR INSURER
IF '($PIECE($GET(^ABMDCLM(AGDUZ2,AGBILL,13,AG13,0)),U,AGP)=AGDA)
QUIT
+41 ;If MCD, same IEN?
+42 IF AGP=7
IF '($PIECE(^ABMDCLM(AGDUZ2,AGBILL,13,AG13,0),U,6)=AGMCDDA)
QUIT
+43 ;Claim number (Site).
SET AGUSED=AGBILL_" ("_$PIECE(^DIC(4,AGDUZ2,0),U)_")"
+44 QUIT
End DoDot:3
IF AGUSED
QUIT
+45 QUIT
End DoDot:2
IF AGUSED
QUIT
+46 QUIT
End DoDot:1
IF AGUSED
QUIT
+47 IF AGUSED
QUIT "Claim # "_AGUSED
+48 QUIT ""
+49 ;
+50 ; MEDICARE MULTIPLE (NJ6,0), [0;4]
+51 ; RAILROAD MULTIPLE (NJ6,0), [0;5]
+52 ; MEDICAID ELIG POINTER (*P9000004'), [0;6]
+53 ; MEDICAID MULTIPLE (NJ4,0), [0;7]
+54 ; PRIVATE INSURANCE MULTIPLE (NJ6,0), [0;8]
