BDGF2 ; IHS/ANMC/LJF - PAT INFO FUNCTION CALLS ; [ 06/01/2004 4:15 PM ]
;;5.3;PIMS;**1001,1003,1004,1005,1007,1008,1009**;MAY 28, 2004
;IHS/ITSC/WAR 05/24/2004 PATCH 1001 Phoenix style terminla digit logic
;IHS/ITSC/LJF 05/13/2005 PATCH 1003 added EP; to CWAD, AGE & INS subroutines
; 06/10/2005 PATCH 1003 terminal digit calculation now parameter driven
; 06/16/2005 PATCH 1003 rewrote medicaid subroutine
;IHS/OIT/LJF 07/27/2005 PATCH 1004 rewrote medicaid subrtn again
; 11/04/2005 PATCH 1004 new HRCN subroutine added
; 12/29/2005 PATCH 1005 removed AGE subroutine - using official API now
; 04/14/2006 PATCH 1005 made HRCNF into a public entry point
;cmi/anch/maw 02/21/2007 PATCH 1007 item 1007.37 modified MCD and MCR not to print "exp" if no expiration date
;cmi/anch/maw 05/08/2008 PATCH 1009 requirement 22 and 31 added NEWINS subroutine
;
HRCN(PAT,SITE) ;EP; return chart number for patient at this site
;called by ADT ITEMS file
I $G(PAT)="" Q "" ;cmi/maw 6/12/2008 PATCH 1009 added for missing pat node in file 44 for appt
Q $P($G(^AUPNPAT(PAT,41,SITE,0)),U,2)
;
HRCND(X) ;EP; add dashes to chart # passed as X
;called by ADT ITEMS file
S X="00000"_X,X=$E(X,$L(X)-5,$L(X))
S X=$E(X,1,2)_"-"_$E(X,3,4)_"-"_$E(X,5,6)
Q X
;
HRCNT(X) ;EP; return terminal digit format of chart # passed as X
;IHS/ITSC/LJF 6/10/2005 PATCH 1003 rewritten to use terminal digit calculation parameter
NEW STYLE S STYLE=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.09,"I") I STYLE="" S STYLE="A"
S X="00000"_X,X=$E(X,$L(X)-5,$L(X))
I STYLE="A" S X=$E(X,5,6)_"-"_$E(X,3,4)_"-"_$E(X,1,2)
E S X=$E(X,5,6)_"-"_$E(X,1,2)_"-"_$E(X,3,4)
Q X
;
;IHS/OIT/LJF 11/04/2005 PATCH 1004 new subroutine (called by DGPWBD for barcoding)
;IHS/OIT/LJF 04/14/2006 PATCH 1005 made into a PEP
HRCNF(PAT,SITE) ;PEP; return facility code and chart # with leading zeros
NEW C,F
S F=$$GET1^DIQ(9999999.06,+$G(SITE),.12),F=$$PAD(F,6)
S C=$$HRCN(+$G(PAT),+$G(SITE)) S C="00000"_C,C=$E(C,$L(C)-5,$L(C))
Q F_C
;
IEN(X) ;EP; return IEN for chart # passed in X
NEW Y S Y=0
F S Y=$O(^AUPNPAT("D",X,Y)) Q:'Y Q:$O(^AUPNPAT("D",X,Y,0))=$G(DUZ(2))
Q +$G(Y)
;
NAMEPRT(DFN,CONVERT) ;EP; return printable name
;CONVERT=1 means convert to mixed case letters
NEW VADM,X
D DEM^VADPT
S X=$P($P(VADM(1),",",2)," ")_" "_$P(VADM(1),",")
I $G(CONVERT) X ^DD("FUNC",14,1)
Q X
;
INSUR(PAT,DATE) ;EP; returns insurance info on DATE sent
NEW INS,X
S INS=""
S X=$$MCR^AUPNPAT(PAT,DATE) I X=1 S INS="MCR/"
S X=$$MCD^AUPNPAT(PAT,DATE) I X=1 S INS=INS_"MCD/"
S X=$$RR^AUPNPAT(PAT,DATE) I X=1 S INS=INS_"RR/" ;cmi/maw PATCH 1009 requirement 71
S X=$$PI^AUPNPAT(PAT,DATE) I X=1 S INS=INS_"PVT/"
I $L(INS)>3 S INS=$E(INS,1,$L(INS)-1)
I INS="" S INS="IHS"
Q $G(INS)
;
NEWINS(P,A,T) ;-- make new insurance call here and then parse based on file number
K BDGNINS,N,BDGRR
N DATE,N
I $G(A) S DATE=+$$GET1^DIQ(405,A,.01,"I")
I '$G(DATE) S DATE=DT
D GETELIG^AGAPIS(.BDGNINS,P,DATE,"E","",0) ;cmi/maw 8/4/2008 changed category back to null from M only PATCH 1009
Q:$G(T)=""
N DA,PR,IN,FL
S DA=0 F S DA=$O(BDGNINS(DA)) Q:DA="" D
. S PR=0 F S PR=$O(BDGNINS(DA,PR)) Q:'PR D
.. S IN=0 F S IN=$O(BDGNINS(DA,PR,IN)) Q:'IN D
... S FL=0 F S FL=$O(BDGNINS(DA,PR,IN,FL)) Q:FL="" D
.... I T="MCR",FL'=9000003 D
..... I FL'=9000003.11 K BDGNINS(DA,PR) Q
..... S BDGCOV=1
..... S N="Medicare #"_$G(BDGNINS(DA,PR,IN,9000003,P_",",.03,"E"))_$G(BDGNINS(DA,PR,IN,9000003,P_",",.04,"E"))
..... N BIENS
..... S BIENS=0 F S BIENS=$O(BDGNINS(DA,PR,IN,9000003.11,BIENS)) Q:BIENS="" D
...... I $G(BDGNINS(DA,PR,IN,9000003.11,BIENS,.02,"E")) S N=N_" exp "_$G(BDGNINS(DA,PR,IN,9000003.11,BIENS,.02,"E"))
.... I T="MCD",FL'=9000004 D
..... I FL'=9000004.11 K BDGNINS(DA,PR) Q
..... N BIEN
..... S BIEN=0 F S BIEN=$O(BDGNINS(DA,PR,IN,9000004,BIEN)) Q:BIEN="" D
...... S N=$S($G(BDGNINS(DA,PR,IN,9000004,BIEN,.11,"E"))]"":$E($G(BDGNINS(DA,PR,IN,9000004,BIEN,.11,"E")),1,15),1:"Medicaid")_" #"_$G(BDGNINS(DA,PR,IN,9000004,BIEN,.03,"E"))
..... S BDGCOV=1
..... N BIENS
..... S BIENS=0 F S BIENS=$O(BDGNINS(DA,PR,IN,9000004.11,BIENS)) Q:BIENS="" D
...... I $G(BDGNINS(DA,PR,IN,9000004.11,BIENS,.02,"E")) S N=N_" exp "_$G(BDGNINS(DA,PR,IN,9000004.11,BIENS,.02,"E"))
.... I T="PI" D
..... I FL=9000003.1 K BDGNINS(DA,PR,IN,9000003.1) Q
..... I FL'=9000006.11,FL'=9000003.1 K BDGNINS(DA,PR) Q
..... N BIENS
..... S BDGCOV=1
..... S BIENS=0 F S BIENS=$O(BDGNINS(DA,PR,IN,9000006.11,BIENS)) Q:BIENS="" D
...... S BDGRR($P(BIENS,","))=$E($G(BDGNINS(DA,PR,IN,9000006.11,BIENS,.01,"E")),1,23)_" #"_$P($G(^AUPNPRVT(P,11,$P(BIENS,","),0)),U,2)
...... ;I $G(BDGNINS(DA,PR,IN,9000006.11,BIENS,.02,"E")) S N=N_" exp "_$G(BDGNINS(DA,PR,IN,9000006.11,BIENS,.02,"E"))
..... K BDGNINS(DA,PR)
.... I T="RR" D
..... I FL'=9000005 K BDGNINS(DA,PR) Q
..... S N="Railroad #"_$G(BDGNINS(DA,PR,IN,9000005,P_",",.04,"E"))_$G(BDGNINS(DA,PR,IN,9000005,P_",",.03,"E"))
..... S BDGCOV=1
..... N BIENS
..... S BIENS=0 F S BIENS=$O(BDGNINS(DA,PR,IN,9000005.11,BIENS)) Q:BIENS="" D
...... I $G(BDGNINS(DA,PR,IN,9000005.11,BIENS,.02,"E")) S N=N_" exp "_$G(BDGNINS(DA,PR,IN,9000005.11,BIENS,.02,"E"))
Q $G(N)
;
MCR(PAT,ADM,EXP) ;EP; medicare coverage for patient (PAT) at admission (ADM)
; returns medicare # & suffix and optionally expiration date
; If EXP=1 returns expiration date
;called by ADT ITEMS file
NEW IEN,X,N,DATE
I ('PAT)!('ADM) Q ""
S IEN=$O(^AUPNMCR("B",PAT,0)) I IEN="" Q "" ;no coverage
S DATE=+$$GET1^DIQ(405,ADM,.01,"I") ;admit date
S X=0 F S X=$O(^AUPNMCR(IEN,"11",X)) Q:'X Q:$G(N)]"" D
. Q:$P(^AUPNMCR(IEN,11,X,0),U)>DATE ;covrg not started
. I $P($G(^AUPNMCR(IEN,11,X,0)),U,2)]"",$P(^(0),U,2)<DATE Q ;stopped
. S N=$$GET1^DIQ(9000003,IEN,.03)_$$GET1^DIQ(9000003,IEN,.04)
. ;I $G(EXP) S N=N_" exp "_$$FMTE^XLFDT($P($G(^AUPNMCR(IEN,11,X,0)),U,2),2) ;cmi/anch/maw 2/21/2007 orig line PATCH 1007 item 1007.37
. I $G(EXP) S N=N_$S($P($G(^AUPNMCR(IEN,11,X,0)),U,2)]"":" exp "_$$FMTE^XLFDT($P($G(^AUPNMCR(IEN,11,X,0)),U,2),2),1:"") ;cmi/anch/maw 2/21/2007 new line to not print exp if no expiration date PATCH 1007 item 1007.37
I $G(N)="" Q ""
S BDGCOV=1 ;patient has coverage
Q "Medicare #"_$G(N)
;
;IHS/ITSC/LJF 6/16/2005 PATCH 1003 rewrote following subroutine
;IHS/OIT/LJF 7/27/2005 PATCH 1004 rewrote code for sites that do not store a MCD name
MCD(PAT,ADM,EXP) ;EP; medicaid coverage for patient PAT at admission ADM
; returns medicaid # if patient coverage on admit date
; EXP (optional), if set to 1, return expiration date
;called by ADT ITEMS file
NEW IEN,IEN2,NUM,DATE,NAME
S DATE=+$$GET1^DIQ(405,ADM,.01,"I") ;admit date
I '$$MCD^AUPNPAT(PAT,DATE) Q "" ;no coverage
S IEN=0 F S IEN=$O(^AUPNMCD("B",PAT,IEN)) Q:'IEN Q:$G(NUM)]"" D
. S IEN2=0 F S IEN2=$O(^AUPNMCD(IEN,"11",IEN2)) Q:'IEN2 Q:$G(NUM)]"" D
. . Q:$P(^AUPNMCD(IEN,11,IEN2,0),U)>DATE ;covrg not started
. . I $P(^AUPNMCD(IEN,11,IEN2,0),U,2)]"",$P(^(0),U,2)<DATE Q ;covrg stoppd
. . ;S NAME=$$GET1^DIQ(9000004,IEN,.11) ;plan name cmi/maw 4/15/2008 orig line
. . S NAME=$E($$GET1^DIQ(9000004,IEN,.11),1,15) ;plan name cmi/maw 4/15/2008 modified line due to date being cut off
. . S NUM=$$GET1^DIQ(9000004,IEN,.03) ;medicaid #
. . ;I $G(EXP) S NUM=NUM_" exp "_$$FMTE^XLFDT($P($G(^AUPNMCD(IEN,11,IEN2,0)),U,2),2) ;cmi/anch/maw 2/21/2007 orig line PATCH 1007 item 1007.37
. . I $G(EXP) S NUM=NUM_$S($P($G(^AUPNMCD(IEN,11,IEN2,0)),U,2)]"":" exp "_$$FMTE^XLFDT($P($G(^AUPNMCD(IEN,11,IEN2,0)),U,2),2),1:"") ;cmi/anch/maw 2/21/2007 new line to not print exp if not expiration date PATCH 1007 item 1007.37
I $G(NUM)="" Q ""
I $G(NAME)="" S NAME="Medicaid"
S BDGCOV=1 ;patient has coverage
Q NAME_" #"_$G(NUM)
;
RR(PAT,ADM,EXP) ;EP; railroad retirment coverage for patient at admission
; If EXP=1 returns expiration date
;called by ADT ITEMS file
NEW IEN,X,N,DATE
S IEN=$O(^AUPNRRE("B",PAT,0)) I IEN="" Q "" ;no coverage
S DATE=+$$GET1^DIQ(405,ADM,.01,"I") ;admit date
S X=0 F S X=$O(^AUPNRRE(IEN,"11",X)) Q:'X Q:$G(N)]"" D
. Q:$P(^AUPNRRE(IEN,11,X,0),U)>DATE ;covrg not started
. I $P(^AUPNRRE(IEN,11,X,0),U,2)]"",$P(^(0),U,2)<DATE Q ;covrg stoppd
. S N=$$GET1^DIQ(9000005,IEN,.03)_$$GET1^DIQ(9000005,IEN,.04)
. I $G(EXP) S N=N_$S($P($G(^AUPNRRE(IEN,11,X,0)),U,2)]"":" exp "_$$FMTE^XLFDT($P($G(^AUPNRRE(IEN,11,X,0)),U,2),2),1:"")
I $G(N)="" Q ""
S BDGCOV=1
Q "Railroad #"_$G(N)
;
INS(PAT,ADM,BDGRR) ;EP; -- private insurance for patient
; Returns BDGRR array
NEW IEN,X,N,DATE,NAME
K BDGRR S IEN=$O(^AUPNPRVT("B",PAT,0)) I 'IEN Q ;no insurance
S DATE=+$$GET1^DIQ(405,ADM,.01,"I") ;admit date
S X=0 F S X=$O(^AUPNPRVT(IEN,"11",X)) Q:'X D
. Q:$P(^AUPNPRVT(IEN,11,X,0),U,6)>DATE ;covrg not started
. I $P(^AUPNPRVT(IEN,11,X,0),U,7)]"",$P(^(0),U,7)<DATE Q ;covrg stoppd
. S N=$P(^AUPNPRVT(IEN,"11",X,0),U,2)
. ;S NAME=$$GET1^DIQ(9999999.18,+^AUPNPRVT(IEN,11,X,0),.01) ;cmi/maw 4/15/2008 orig line
. S NAME=$E($$GET1^DIQ(9999999.18,+^AUPNPRVT(IEN,11,X,0),.01),1,23) ;cmi/maw 4/15/2008 modified for name length on a sheet
. S BDGRR(X)=NAME_" #"_N ;policy name & #
I '$D(BDGRR) Q
S BDGCOV=1 ;patient has coverage
Q
;
STATUS(PAT) ;PEP; returns patient's current status
NEW X
I $$DEAD(PAT) Q "Patient Died on "_$$GET1^DIQ(2,PAT,.351)
;
;IHS/ITSC/WAR 5/5/03 P67 mod to handle trucated displayed field
;I $D(^DPT(PAT,.1)) D Q "Patient currently an "_X_" on "_^DPT(PAT,.1)_Y
I $D(^DPT(PAT,.1)) D Q "Pt currently an "_X_" on "_^DPT(PAT,.1)_Y
. I $$GET1^DIQ(2,PAT,.103)["OBSERVATION" S X="Observation Patient"
. E S X="Inpatient"
. S Y=$$GET1^DIQ(2,PAT,401.3) I Y]"" S Y=" ("_Y_")"
;
I $O(^ADGIC(DFN,"D",0)) Q "Active Incomplete Chart"
I $O(^ADGDSI(DFN,"DT",0)) Q "Active Day Surgery Incomplete Chart"
;
S X=$O(^ADGDS(DFN,"DS",DT)) I X\1=DT Q "Active Day Surgery Patient"
NEW DATE,X S DATE=9999999-DT,X=DATE-.0001
S X=$O(^SRF("AIHS3",DFN,X))
I X\1=DATE Q "Day Surgery/Same Day Admit Patient"
;
Q "Outpatient"
;
CWAD(PAT) ;EP; -- returns cwad initials for patient PAT;IHS/ITSC/LJF PATCH 1003
NEW X,DFN,GMRPCWAD
S X="GMRPNOR1" X ^%ZOSF("TEST") I '$T Q " "
S X=$$CWAD^GMRPNOR1(+PAT) I '$L(X) Q " "
S X="<"_X_">",X=$E(X_" ",1,7)
Q X
;
DEAD(PAT) ;EP; returns 1 if patient has died
Q $S($G(^DPT(PAT,.35)):1,1:0)
;
DOD(PAT) ;EP; returns patient's date of death
Q $$GET1^DIQ(2,PAT,.351)
;
LASTREG(PAT) ;EP; returns date of last Registration update
Q $$GET1^DIQ(9000001,PAT,.03)
;
COMMCOD(PAT) ;EP; returns formatted current community code
;called by ADT ITEMS file
I '$G(PAT) Q ""
NEW X
S X=$$GET1^DIQ(9999999.05,+$$GET1^DIQ(9000001,PAT,1117,"I"),.08)
;IHS/ITSC/WAR 6/1/2004 PATCH #1001 correct the order of display
;Q $S(X="":"",1:$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,7))
Q $S(X="":"",1:$E(X,5,7)_"-"_$E(X,3,4)_"-"_$E(X,1,2))
;
TRBCOD(PAT) ;EP; returns tribe and code
;called by ADT ITEMS file
I '$G(PAT) Q ""
NEW X,Y
S X=$E($$GET1^DIQ(9000001,PAT,1108),1,3) ;1st 3 letters of tribe
S Y=$$GET1^DIQ(9999999.03,+$$GET1^DIQ(9000001,PAT,1108,"I"),.02)
Q X_Y
;
ADDRS(PAT) ;EP; returns single line patient address
;called by ADT ITEMS file
I '$G(PAT) Q ""
NEW X
I '$D(^DPT(PAT,.11)) Q ""
S X=$$GET1^DIQ(2,DFN,.111)_" "_$$GET1^DIQ(2,DFN,.114)
S X=X_", "_$$GET1^DIQ(5,+$$GET1^DIQ(2,DFN,.115,"I"),1) ;state abbrev
S X=X_" "_$$GET1^DIQ(2,DFN,.116)
Q X
;
NOKADD(PAT) ;EP; returns single line address for patient's next of kin
;called by ADT ITEMS file
I '$G(PAT) Q ""
NEW X
I '$D(^DPT(PAT,.21)) Q ""
S X=$$GET1^DIQ(2,DFN,.213)_" "_$$GET1^DIQ(2,DFN,.216)
S X=X_", "_$$GET1^DIQ(5,+$$GET1^DIQ(2,DFN,.217,"I"),1) ;state abbrev
S X=X_" "_$$GET1^DIQ(2,DFN,.218)
Q X
;
ECADD(PAT) ;EP; returns single line address for patient's emergency contact
;called by ADT ITEMS file
I '$G(PAT) Q ""
NEW X
I '$D(^DPT(PAT,.33)) Q ""
S X=$$GET1^DIQ(2,DFN,.333)_" "_$$GET1^DIQ(2,DFN,.336)
S X=X_", "_$$GET1^DIQ(5,+$$GET1^DIQ(2,DFN,.337,"I"),1) ;state abbrev
S X=X_" "_$$GET1^DIQ(2,DFN,.338)
Q X
;
PAD(D,L) ;EP -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
BDGF2 ; IHS/ANMC/LJF - PAT INFO FUNCTION CALLS ; [ 06/01/2004 4:15 PM ]
+1 ;;5.3;PIMS;**1001,1003,1004,1005,1007,1008,1009**;MAY 28, 2004
+2 ;IHS/ITSC/WAR 05/24/2004 PATCH 1001 Phoenix style terminla digit logic
+3 ;IHS/ITSC/LJF 05/13/2005 PATCH 1003 added EP; to CWAD, AGE & INS subroutines
+4 ; 06/10/2005 PATCH 1003 terminal digit calculation now parameter driven
+5 ; 06/16/2005 PATCH 1003 rewrote medicaid subroutine
+6 ;IHS/OIT/LJF 07/27/2005 PATCH 1004 rewrote medicaid subrtn again
+7 ; 11/04/2005 PATCH 1004 new HRCN subroutine added
+8 ; 12/29/2005 PATCH 1005 removed AGE subroutine - using official API now
+9 ; 04/14/2006 PATCH 1005 made HRCNF into a public entry point
+10 ;cmi/anch/maw 02/21/2007 PATCH 1007 item 1007.37 modified MCD and MCR not to print "exp" if no expiration date
+11 ;cmi/anch/maw 05/08/2008 PATCH 1009 requirement 22 and 31 added NEWINS subroutine
+12 ;
HRCN(PAT,SITE) ;EP; return chart number for patient at this site
+1 ;called by ADT ITEMS file
+2 ;cmi/maw 6/12/2008 PATCH 1009 added for missing pat node in file 44 for appt
IF $GET(PAT)=""
QUIT ""
+3 QUIT $PIECE($GET(^AUPNPAT(PAT,41,SITE,0)),U,2)
+4 ;
HRCND(X) ;EP; add dashes to chart # passed as X
+1 ;called by ADT ITEMS file
+2 SET X="00000"_X
SET X=$EXTRACT(X,$LENGTH(X)-5,$LENGTH(X))
+3 SET X=$EXTRACT(X,1,2)_"-"_$EXTRACT(X,3,4)_"-"_$EXTRACT(X,5,6)
+4 QUIT X
+5 ;
HRCNT(X) ;EP; return terminal digit format of chart # passed as X
+1 ;IHS/ITSC/LJF 6/10/2005 PATCH 1003 rewritten to use terminal digit calculation parameter
+2 NEW STYLE
SET STYLE=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.09,"I")
IF STYLE=""
SET STYLE="A"
+3 SET X="00000"_X
SET X=$EXTRACT(X,$LENGTH(X)-5,$LENGTH(X))
+4 IF STYLE="A"
SET X=$EXTRACT(X,5,6)_"-"_$EXTRACT(X,3,4)_"-"_$EXTRACT(X,1,2)
+5 IF '$TEST
SET X=$EXTRACT(X,5,6)_"-"_$EXTRACT(X,1,2)_"-"_$EXTRACT(X,3,4)
+6 QUIT X
+7 ;
+8 ;IHS/OIT/LJF 11/04/2005 PATCH 1004 new subroutine (called by DGPWBD for barcoding)
+9 ;IHS/OIT/LJF 04/14/2006 PATCH 1005 made into a PEP
HRCNF(PAT,SITE) ;PEP; return facility code and chart # with leading zeros
+1 NEW C,F
+2 SET F=$$GET1^DIQ(9999999.06,+$GET(SITE),.12)
SET F=$$PAD(F,6)
+3 SET C=$$HRCN(+$GET(PAT),+$GET(SITE))
SET C="00000"_C
SET C=$EXTRACT(C,$LENGTH(C)-5,$LENGTH(C))
+4 QUIT F_C
+5 ;
IEN(X) ;EP; return IEN for chart # passed in X
+1 NEW Y
SET Y=0
+2 FOR
SET Y=$ORDER(^AUPNPAT("D",X,Y))
IF 'Y
QUIT
IF $ORDER(^AUPNPAT("D",X,Y,0))=$GET(DUZ(2))
QUIT
+3 QUIT +$GET(Y)
+4 ;
NAMEPRT(DFN,CONVERT) ;EP; return printable name
+1 ;CONVERT=1 means convert to mixed case letters
+2 NEW VADM,X
+3 DO DEM^VADPT
+4 SET X=$PIECE($PIECE(VADM(1),",",2)," ")_" "_$PIECE(VADM(1),",")
+5 IF $GET(CONVERT)
XECUTE ^DD("FUNC",14,1)
+6 QUIT X
+7 ;
INSUR(PAT,DATE) ;EP; returns insurance info on DATE sent
+1 NEW INS,X
+2 SET INS=""
+3 SET X=$$MCR^AUPNPAT(PAT,DATE)
IF X=1
SET INS="MCR/"
+4 SET X=$$MCD^AUPNPAT(PAT,DATE)
IF X=1
SET INS=INS_"MCD/"
+5 ;cmi/maw PATCH 1009 requirement 71
SET X=$$RR^AUPNPAT(PAT,DATE)
IF X=1
SET INS=INS_"RR/"
+6 SET X=$$PI^AUPNPAT(PAT,DATE)
IF X=1
SET INS=INS_"PVT/"
+7 IF $LENGTH(INS)>3
SET INS=$EXTRACT(INS,1,$LENGTH(INS)-1)
+8 IF INS=""
SET INS="IHS"
+9 QUIT $GET(INS)
+10 ;
NEWINS(P,A,T) ;-- make new insurance call here and then parse based on file number
+1 KILL BDGNINS,N,BDGRR
+2 NEW DATE,N
+3 IF $GET(A)
SET DATE=+$$GET1^DIQ(405,A,.01,"I")
+4 IF '$GET(DATE)
SET DATE=DT
+5 ;cmi/maw 8/4/2008 changed category back to null from M only PATCH 1009
DO GETELIG^AGAPIS(.BDGNINS,P,DATE,"E","",0)
+6 IF $GET(T)=""
QUIT
+7 NEW DA,PR,IN,FL
+8 SET DA=0
FOR
SET DA=$ORDER(BDGNINS(DA))
IF DA=""
QUIT
Begin DoDot:1
+9 SET PR=0
FOR
SET PR=$ORDER(BDGNINS(DA,PR))
IF 'PR
QUIT
Begin DoDot:2
+10 SET IN=0
FOR
SET IN=$ORDER(BDGNINS(DA,PR,IN))
IF 'IN
QUIT
Begin DoDot:3
+11 SET FL=0
FOR
SET FL=$ORDER(BDGNINS(DA,PR,IN,FL))
IF FL=""
QUIT
Begin DoDot:4
+12 IF T="MCR"
IF FL'=9000003
Begin DoDot:5
+13 IF FL'=9000003.11
KILL BDGNINS(DA,PR)
QUIT
+14 SET BDGCOV=1
+15 SET N="Medicare #"_$GET(BDGNINS(DA,PR,IN,9000003,P_",",.03,"E"))_$GET(BDGNINS(DA,PR,IN,9000003,P_",",.04,"E"))
+16 NEW BIENS
+17 SET BIENS=0
FOR
SET BIENS=$ORDER(BDGNINS(DA,PR,IN,9000003.11,BIENS))
IF BIENS=""
QUIT
Begin DoDot:6
+18 IF $GET(BDGNINS(DA,PR,IN,9000003.11,BIENS,.02,"E"))
SET N=N_" exp "_$GET(BDGNINS(DA,PR,IN,9000003.11,BIENS,.02,"E"))
End DoDot:6
End DoDot:5
+19 IF T="MCD"
IF FL'=9000004
Begin DoDot:5
+20 IF FL'=9000004.11
KILL BDGNINS(DA,PR)
QUIT
+21 NEW BIEN
+22 SET BIEN=0
FOR
SET BIEN=$ORDER(BDGNINS(DA,PR,IN,9000004,BIEN))
IF BIEN=""
QUIT
Begin DoDot:6
+23 SET N=$SELECT($GET(BDGNINS(DA,PR,IN,9000004,BIEN,.11,"E"))]"":$EXTRACT($GET(BDGNINS(DA,PR,IN,9000004,BIEN,.11,"E")),1,15),1:"Medicaid")_" #"_$GET(BDGNINS(DA,PR,IN,9000004,BIEN,.03,"E"))
End DoDot:6
+24 SET BDGCOV=1
+25 NEW BIENS
+26 SET BIENS=0
FOR
SET BIENS=$ORDER(BDGNINS(DA,PR,IN,9000004.11,BIENS))
IF BIENS=""
QUIT
Begin DoDot:6
+27 IF $GET(BDGNINS(DA,PR,IN,9000004.11,BIENS,.02,"E"))
SET N=N_" exp "_$GET(BDGNINS(DA,PR,IN,9000004.11,BIENS,.02,"E"))
End DoDot:6
End DoDot:5
+28 IF T="PI"
Begin DoDot:5
+29 IF FL=9000003.1
KILL BDGNINS(DA,PR,IN,9000003.1)
QUIT
+30 IF FL'=9000006.11
IF FL'=9000003.1
KILL BDGNINS(DA,PR)
QUIT
+31 NEW BIENS
+32 SET BDGCOV=1
+33 SET BIENS=0
FOR
SET BIENS=$ORDER(BDGNINS(DA,PR,IN,9000006.11,BIENS))
IF BIENS=""
QUIT
Begin DoDot:6
+34 SET BDGRR($PIECE(BIENS,","))=$EXTRACT($GET(BDGNINS(DA,PR,IN,9000006.11,BIENS,.01,"E")),1,23)_" #"_$PIECE($GET(^AUPNPRVT(P,11,$PIECE(BIENS,","),0)),U,2)
+35 ;I $G(BDGNINS(DA,PR,IN,9000006.11,BIENS,.02,"E")) S N=N_" exp "_$G(BDGNINS(DA,PR,IN,9000006.11,BIENS,.02,"E"))
End DoDot:6
+36 KILL BDGNINS(DA,PR)
End DoDot:5
+37 IF T="RR"
Begin DoDot:5
+38 IF FL'=9000005
KILL BDGNINS(DA,PR)
QUIT
+39 SET N="Railroad #"_$GET(BDGNINS(DA,PR,IN,9000005,P_",",.04,"E"))_$GET(BDGNINS(DA,PR,IN,9000005,P_",",.03,"E"))
+40 SET BDGCOV=1
+41 NEW BIENS
+42 SET BIENS=0
FOR
SET BIENS=$ORDER(BDGNINS(DA,PR,IN,9000005.11,BIENS))
IF BIENS=""
QUIT
Begin DoDot:6
+43 IF $GET(BDGNINS(DA,PR,IN,9000005.11,BIENS,.02,"E"))
SET N=N_" exp "_$GET(BDGNINS(DA,PR,IN,9000005.11,BIENS,.02,"E"))
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+44 QUIT $GET(N)
+45 ;
MCR(PAT,ADM,EXP) ;EP; medicare coverage for patient (PAT) at admission (ADM)
+1 ; returns medicare # & suffix and optionally expiration date
+2 ; If EXP=1 returns expiration date
+3 ;called by ADT ITEMS file
+4 NEW IEN,X,N,DATE
+5 IF ('PAT)!('ADM)
QUIT ""
+6 ;no coverage
SET IEN=$ORDER(^AUPNMCR("B",PAT,0))
IF IEN=""
QUIT ""
+7 ;admit date
SET DATE=+$$GET1^DIQ(405,ADM,.01,"I")
+8 SET X=0
FOR
SET X=$ORDER(^AUPNMCR(IEN,"11",X))
IF 'X
QUIT
IF $GET(N)]""
QUIT
Begin DoDot:1
+9 ;covrg not started
IF $PIECE(^AUPNMCR(IEN,11,X,0),U)>DATE
QUIT
+10 ;stopped
IF $PIECE($GET(^AUPNMCR(IEN,11,X,0)),U,2)]""
IF $PIECE(^(0),U,2)<DATE
QUIT
+11 SET N=$$GET1^DIQ(9000003,IEN,.03)_$$GET1^DIQ(9000003,IEN,.04)
+12 ;I $G(EXP) S N=N_" exp "_$$FMTE^XLFDT($P($G(^AUPNMCR(IEN,11,X,0)),U,2),2) ;cmi/anch/maw 2/21/2007 orig line PATCH 1007 item 1007.37
+13 ;cmi/anch/maw 2/21/2007 new line to not print exp if no expiration date PATCH 1007 item 1007.37
IF $GET(EXP)
SET N=N_$SELECT($PIECE($GET(^AUPNMCR(IEN,11,X,0)),U,2)]"":" exp "_$$FMTE^XLFDT($PIECE($GET(^AUPNMCR(IEN,11,X,0)),U,2),2),1:"")
End DoDot:1
+14 IF $GET(N)=""
QUIT ""
+15 ;patient has coverage
SET BDGCOV=1
+16 QUIT "Medicare #"_$GET(N)
+17 ;
+18 ;IHS/ITSC/LJF 6/16/2005 PATCH 1003 rewrote following subroutine
+19 ;IHS/OIT/LJF 7/27/2005 PATCH 1004 rewrote code for sites that do not store a MCD name
MCD(PAT,ADM,EXP) ;EP; medicaid coverage for patient PAT at admission ADM
+1 ; returns medicaid # if patient coverage on admit date
+2 ; EXP (optional), if set to 1, return expiration date
+3 ;called by ADT ITEMS file
+4 NEW IEN,IEN2,NUM,DATE,NAME
+5 ;admit date
SET DATE=+$$GET1^DIQ(405,ADM,.01,"I")
+6 ;no coverage
IF '$$MCD^AUPNPAT(PAT,DATE)
QUIT ""
+7 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNMCD("B",PAT,IEN))
IF 'IEN
QUIT
IF $GET(NUM)]""
QUIT
Begin DoDot:1
+8 SET IEN2=0
FOR
SET IEN2=$ORDER(^AUPNMCD(IEN,"11",IEN2))
IF 'IEN2
QUIT
IF $GET(NUM)]""
QUIT
Begin DoDot:2
+9 ;covrg not started
IF $PIECE(^AUPNMCD(IEN,11,IEN2,0),U)>DATE
QUIT
+10 ;covrg stoppd
IF $PIECE(^AUPNMCD(IEN,11,IEN2,0),U,2)]""
IF $PIECE(^(0),U,2)<DATE
QUIT
+11 ;S NAME=$$GET1^DIQ(9000004,IEN,.11) ;plan name cmi/maw 4/15/2008 orig line
+12 ;plan name cmi/maw 4/15/2008 modified line due to date being cut off
SET NAME=$EXTRACT($$GET1^DIQ(9000004,IEN,.11),1,15)
+13 ;medicaid #
SET NUM=$$GET1^DIQ(9000004,IEN,.03)
+14 ;I $G(EXP) S NUM=NUM_" exp "_$$FMTE^XLFDT($P($G(^AUPNMCD(IEN,11,IEN2,0)),U,2),2) ;cmi/anch/maw 2/21/2007 orig line PATCH 1007 item 1007.37
+15 ;cmi/anch/maw 2/21/2007 new line to not print exp if not expiration date PATCH 1007 item 1007.37
IF $GET(EXP)
SET NUM=NUM_$SELECT($PIECE($GET(^AUPNMCD(IEN,11,IEN2,0)),U,2)]"":" exp "_$$FMTE^XLFDT($PIECE($GET(^AUPNMCD(IEN,11,IEN2,0)),U,2),2),1:"")
End DoDot:2
End DoDot:1
+16 IF $GET(NUM)=""
QUIT ""
+17 IF $GET(NAME)=""
SET NAME="Medicaid"
+18 ;patient has coverage
SET BDGCOV=1
+19 QUIT NAME_" #"_$GET(NUM)
+20 ;
RR(PAT,ADM,EXP) ;EP; railroad retirment coverage for patient at admission
+1 ; If EXP=1 returns expiration date
+2 ;called by ADT ITEMS file
+3 NEW IEN,X,N,DATE
+4 ;no coverage
SET IEN=$ORDER(^AUPNRRE("B",PAT,0))
IF IEN=""
QUIT ""
+5 ;admit date
SET DATE=+$$GET1^DIQ(405,ADM,.01,"I")
+6 SET X=0
FOR
SET X=$ORDER(^AUPNRRE(IEN,"11",X))
IF 'X
QUIT
IF $GET(N)]""
QUIT
Begin DoDot:1
+7 ;covrg not started
IF $PIECE(^AUPNRRE(IEN,11,X,0),U)>DATE
QUIT
+8 ;covrg stoppd
IF $PIECE(^AUPNRRE(IEN,11,X,0),U,2)]""
IF $PIECE(^(0),U,2)<DATE
QUIT
+9 SET N=$$GET1^DIQ(9000005,IEN,.03)_$$GET1^DIQ(9000005,IEN,.04)
+10 IF $GET(EXP)
SET N=N_$SELECT($PIECE($GET(^AUPNRRE(IEN,11,X,0)),U,2)]"":" exp "_$$FMTE^XLFDT($PIECE($GET(^AUPNRRE(IEN,11,X,0)),U,2),2),1:"")
End DoDot:1
+11 IF $GET(N)=""
QUIT ""
+12 SET BDGCOV=1
+13 QUIT "Railroad #"_$GET(N)
+14 ;
INS(PAT,ADM,BDGRR) ;EP; -- private insurance for patient
+1 ; Returns BDGRR array
+2 NEW IEN,X,N,DATE,NAME
+3 ;no insurance
KILL BDGRR
SET IEN=$ORDER(^AUPNPRVT("B",PAT,0))
IF 'IEN
QUIT
+4 ;admit date
SET DATE=+$$GET1^DIQ(405,ADM,.01,"I")
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPRVT(IEN,"11",X))
IF 'X
QUIT
Begin DoDot:1
+6 ;covrg not started
IF $PIECE(^AUPNPRVT(IEN,11,X,0),U,6)>DATE
QUIT
+7 ;covrg stoppd
IF $PIECE(^AUPNPRVT(IEN,11,X,0),U,7)]""
IF $PIECE(^(0),U,7)<DATE
QUIT
+8 SET N=$PIECE(^AUPNPRVT(IEN,"11",X,0),U,2)
+9 ;S NAME=$$GET1^DIQ(9999999.18,+^AUPNPRVT(IEN,11,X,0),.01) ;cmi/maw 4/15/2008 orig line
+10 ;cmi/maw 4/15/2008 modified for name length on a sheet
SET NAME=$EXTRACT($$GET1^DIQ(9999999.18,+^AUPNPRVT(IEN,11,X,0),.01),1,23)
+11 ;policy name & #
SET BDGRR(X)=NAME_" #"_N
End DoDot:1
+12 IF '$DATA(BDGRR)
QUIT
+13 ;patient has coverage
SET BDGCOV=1
+14 QUIT
+15 ;
STATUS(PAT) ;PEP; returns patient's current status
+1 NEW X
+2 IF $$DEAD(PAT)
QUIT "Patient Died on "_$$GET1^DIQ(2,PAT,.351)
+3 ;
+4 ;IHS/ITSC/WAR 5/5/03 P67 mod to handle trucated displayed field
+5 ;I $D(^DPT(PAT,.1)) D Q "Patient currently an "_X_" on "_^DPT(PAT,.1)_Y
+6 IF $DATA(^DPT(PAT,.1))
Begin DoDot:1
+7 IF $$GET1^DIQ(2,PAT,.103)["OBSERVATION"
SET X="Observation Patient"
+8 IF '$TEST
SET X="Inpatient"
+9 SET Y=$$GET1^DIQ(2,PAT,401.3)
IF Y]""
SET Y=" ("_Y_")"
End DoDot:1
QUIT "Pt currently an "_X_" on "_^DPT(PAT,.1)_Y
+10 ;
+11 IF $ORDER(^ADGIC(DFN,"D",0))
QUIT "Active Incomplete Chart"
+12 IF $ORDER(^ADGDSI(DFN,"DT",0))
QUIT "Active Day Surgery Incomplete Chart"
+13 ;
+14 SET X=$ORDER(^ADGDS(DFN,"DS",DT))
IF X\1=DT
QUIT "Active Day Surgery Patient"
+15 NEW DATE,X
SET DATE=9999999-DT
SET X=DATE-.0001
+16 SET X=$ORDER(^SRF("AIHS3",DFN,X))
+17 IF X\1=DATE
QUIT "Day Surgery/Same Day Admit Patient"
+18 ;
+19 QUIT "Outpatient"
+20 ;
CWAD(PAT) ;EP; -- returns cwad initials for patient PAT;IHS/ITSC/LJF PATCH 1003
+1 NEW X,DFN,GMRPCWAD
+2 SET X="GMRPNOR1"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT " "
+3 SET X=$$CWAD^GMRPNOR1(+PAT)
IF '$LENGTH(X)
QUIT " "
+4 SET X="<"_X_">"
SET X=$EXTRACT(X_" ",1,7)
+5 QUIT X
+6 ;
DEAD(PAT) ;EP; returns 1 if patient has died
+1 QUIT $SELECT($GET(^DPT(PAT,.35)):1,1:0)
+2 ;
DOD(PAT) ;EP; returns patient's date of death
+1 QUIT $$GET1^DIQ(2,PAT,.351)
+2 ;
LASTREG(PAT) ;EP; returns date of last Registration update
+1 QUIT $$GET1^DIQ(9000001,PAT,.03)
+2 ;
COMMCOD(PAT) ;EP; returns formatted current community code
+1 ;called by ADT ITEMS file
+2 IF '$GET(PAT)
QUIT ""
+3 NEW X
+4 SET X=$$GET1^DIQ(9999999.05,+$$GET1^DIQ(9000001,PAT,1117,"I"),.08)
+5 ;IHS/ITSC/WAR 6/1/2004 PATCH #1001 correct the order of display
+6 ;Q $S(X="":"",1:$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,7))
+7 QUIT $SELECT(X="":"",1:$EXTRACT(X,5,7)_"-"_$EXTRACT(X,3,4)_"-"_$EXTRACT(X,1,2))
+8 ;
TRBCOD(PAT) ;EP; returns tribe and code
+1 ;called by ADT ITEMS file
+2 IF '$GET(PAT)
QUIT ""
+3 NEW X,Y
+4 ;1st 3 letters of tribe
SET X=$EXTRACT($$GET1^DIQ(9000001,PAT,1108),1,3)
+5 SET Y=$$GET1^DIQ(9999999.03,+$$GET1^DIQ(9000001,PAT,1108,"I"),.02)
+6 QUIT X_Y
+7 ;
ADDRS(PAT) ;EP; returns single line patient address
+1 ;called by ADT ITEMS file
+2 IF '$GET(PAT)
QUIT ""
+3 NEW X
+4 IF '$DATA(^DPT(PAT,.11))
QUIT ""
+5 SET X=$$GET1^DIQ(2,DFN,.111)_" "_$$GET1^DIQ(2,DFN,.114)
+6 ;state abbrev
SET X=X_", "_$$GET1^DIQ(5,+$$GET1^DIQ(2,DFN,.115,"I"),1)
+7 SET X=X_" "_$$GET1^DIQ(2,DFN,.116)
+8 QUIT X
+9 ;
NOKADD(PAT) ;EP; returns single line address for patient's next of kin
+1 ;called by ADT ITEMS file
+2 IF '$GET(PAT)
QUIT ""
+3 NEW X
+4 IF '$DATA(^DPT(PAT,.21))
QUIT ""
+5 SET X=$$GET1^DIQ(2,DFN,.213)_" "_$$GET1^DIQ(2,DFN,.216)
+6 ;state abbrev
SET X=X_", "_$$GET1^DIQ(5,+$$GET1^DIQ(2,DFN,.217,"I"),1)
+7 SET X=X_" "_$$GET1^DIQ(2,DFN,.218)
+8 QUIT X
+9 ;
ECADD(PAT) ;EP; returns single line address for patient's emergency contact
+1 ;called by ADT ITEMS file
+2 IF '$GET(PAT)
QUIT ""
+3 NEW X
+4 IF '$DATA(^DPT(PAT,.33))
QUIT ""
+5 SET X=$$GET1^DIQ(2,DFN,.333)_" "_$$GET1^DIQ(2,DFN,.336)
+6 ;state abbrev
SET X=X_", "_$$GET1^DIQ(5,+$$GET1^DIQ(2,DFN,.337,"I"),1)
+7 SET X=X_" "_$$GET1^DIQ(2,DFN,.338)
+8 QUIT X
+9 ;
PAD(D,L) ;EP -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
