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

BDGF2.m

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