VENPCC1C ; IHS/OIT/GIS - MORE DATA MINING FOR ENCOUNTER FORMS 09 Mar 2004 8:15 AM ;
;;2.6;PCC+;;NOV 12, 2007
;
; ONLY THE x FIELDS ARE POPULTED HERE UNDER VER 2.5. NEW CODE IS IN VENPCCC
; ART PKG FOR ALLERGIES IS SUPPORTED HERE
;
XSET(SS,DFN,MIEN,MMF,CLASS,DEFEF) ; EP-SET MAIL MERGE FIELDS INTO TMP ARRAY
N PTYPE,X,VAL,TAG,TMP
S PTYPE=$P($G(^VEN(SS,MIEN,0)),U,9)
S TMP=$NA(^TMP("VEN PRNT",$J,1))
I '$$OK(SS,DFN,MIEN,PTYPE,CLASS,DEFEF) Q 0 ; FIELD FAILED TO MATCH PATIENT TYPE
S X=^VEN(SS,MIEN,0)
S VAL=$P(X,U)
S TAG=$G(^VEN(SS,MIEN,1))
I TAG'="",TAG?1.8UN1"^VENPCC"1.2UN X "I $L($T("_TAG_"))" I X ("N X S VAL=$$"_TAG_"(DFN)") ; COMPUTED VALUE ; TO PREVENT PROBLEMS CAUSED BY INVALID DATABASE ENTRY
I SS=7.94 S ^TMP("VEN PRNT",$J,1,MMF)=$P(X,U,4)_VAL_$P(X,U,5) Q 1
S ^TMP("VEN PRNT",$J,1,MMF)=VAL
C1 S %=$P(X,U,6) I %'="" S @TMP@(MMF_"a")=% ; CODE #1
C2 S %=$P(X,U,7) I %'="" S @TMP@(MMF_"b")=% ; CODE #2
Q 1
;
OK(SS,DFN,MIEN,PTYPE,CLASS,DEFEF) ; EP-CHECK FOR PATIENT TYPE MATCH
N TAG,X,FORM
I PTYPE'=CLASS Q 0
S TAG=$G(^VEN(SS,MIEN,2)) I TAG="" Q 1
X ("S X=$$"_TAG_"(DFN)")
Q X
;
ALLERG(APCHSPAT) ; EP-ALLERGIES
N APCHSDFN,IIEN,ICD,TOT,OK,MAX,APCHSP,APCHSNKA
I $P($G(^VEN(7.5,$$CFG^VENPCCU,0)),U,23) D ART^VENPCC1L(APCHSPAT) Q ; USE THE ADVERSE RXN TRACKING PKG, VER 2.5
S APCHSDFN="",TOT=0,MAX=$P($G(^VEN(7.41,+$G(DEFEF),2)),U,5) I 'MAX S MAX=5
F Q:TOT=(MAX+1) S APCHSDFN=$O(^AUPNPROB("AC",+$G(APCHSPAT),APCHSDFN)) Q:'APCHSDFN D
. S IIEN=+$P($G(^AUPNPROB(APCHSDFN,0)),U)
. S APCHSP=$P($G(^ICD9(IIEN,0)),U)
. I $L(APCHSP) S APCHSNKA=0 D PROBACHK^APCHS40 I $T,'APCHSNKA D SETA(APCHSDFN)
. Q
Q
;
SETA(PIEN) ;
N NARR,NIEN,MAXNARR
S MAXNARR=$P($G(^VEN(7.41,$G(DEFEF),14)),U,6) I 'MAXNARR S MAXNARR=32 ; MAX STG LENGTH
S NIEN=+$P($G(^AUPNPROB(PIEN,0)),U,5)
S NARR=$P($G(^AUTNPOV(NIEN,0)),U)
I '$L(NARR) Q
S TOT=TOT+1
I TOT=(MAX+1) S @TMP@(1,("a"_MAX))="More allergies on Hlth Summary!" Q
S @TMP@(1,("a"_TOT))=$E(NARR,1,MAXNARR)
Q
;
INS(DFN) ; EP-- send the patient dfn and get back 3p elig
Q $$TPC(DFN)
;
CLASS(DFN) ; EP-GIVEN THE DFN RETURN THE PATIENT CLASS FOR SITE PREFERENCES
; 1=INFANT,2=CHILD,3=ADULT MALE,4=ADULT FEMALE
N AGE,SEX,DOB,X
S X=$P($G(^DPT(DFN,0)),U,2,3),DOB=$P(X,U,2),SEX=$P(X,U)
I DOB,$L(SEX)
E Q ""
S AGE=(DT-DOB)\10000
S X=$S(AGE<2:1,AGE<13:2,SEX="M":3,1:4)
Q X
;
IF ; EP-ENABLE IMMUNIZATION FORECASTING AT SITES THAT SUPPORT IMMUNIZATION FORECASTING
I $L($T(VER^BILOGO)),$$VER^BILOGO>7.99,$L($T(IMMBI^BIAPCHS)) N TMP,% S TMP="IMM",%=$$NEWIMM^VENPCCS2(DFN) K @TMP,% Q ; FOR IMM PKG 8.0 ; PATCHED BY GIS/ITSC
N I,TOT,X,Y,Z,%,N,LINE,BIDE,IMM,GRP,DATE,PRE,POST,TMP
S TMP=$NA(^TMP("VEN PRNT",$J,1))
S (LINE,PRE,POST)="",TOT=7
S %=$O(^VEN(7.94,"B","IMMUNIZATIONS",0)) I % S PRE=$P($G(^VEN(7.94,%,0)),U,4),POST=$P($G(^VEN(7.94,%,0)),U,5)
F I=8,26,27,60,33,44,57 S BIDE(I)=""
D IMMHX^BIRPC(.LINE,DFN,.BIDE)
F I=9:1:25 S @TMP@("h"_I)="" ; CLEAR OUT OLD VALUES FOR IMMUNIZATIONS
S Z=$L(LINE,U)-1
F N=1:1:Z S X=$P(LINE,U,N) I $L(X) D
. S IMM=$P(X,"|",2),DATE=$P(X,"|",8),GRP=$P(X,"|",4)
. I $L(IMM),$L(DATE),$L(GRP)
. E Q
. S GRP(GRP)=PRE_IMM_" "_DATE_POST
. Q
S GRP="" F TOT=9:1 S GRP=$O(GRP(GRP)) Q:GRP="" S @TMP@("h"_TOT)=GRP(GRP)
Q
;
IX(X,CMD,IEN) ; EP-1=SET, 2=MMF, 3=DELETE
I $G(X)="" Q
I '$D(^VEN(7.93,+$G(IEN),0)) Q
I +$G(CMD)<1,+$G(CMD)>4 Q
N STG,MMF,SET,%
S STG=^VEN(7.93,IEN,0)
I CMD#2 S SET=X,MMF=$P($G(^VEN(7.42,+$P(STG,U,3),0)),U)
E S MMF=$P($G(^VEN(7.42,X,0)),U),SET=$P(STG,U,2)
I 'SET!(MMF="") Q
I CMD<3 S ^VEN(7.93,"AS",SET,MMF,IEN)="" Q
K ^VEN(7.93,"AS",SET,MMF,IEN)
Q
;
AX(X,CMD,IEN) ; EP-1=SET, 2=OGRP, 3=PGRP, 4=DELETE
I $G(X)="" Q
I '$D(^VEN(7.93,+$G(IEN),0)) Q
I +$G(CMD)<1,+$G(CMD)>4 Q
N STG,PGRP,SET,%,GRP,FLD
S STG=^VEN(7.93,IEN,0)
I CMD=1 S SET=X,PGRP=$P(STG,U,9),FLD=$P(STG,U,8)
I CMD=2 S FLD=X,SET=$P(STG,U,2),PGRP=$P(STG,U,9)
I CMD=3 S PGRP=X,SET=$P(STG,U,2),FLD=$P(STG,U,8)
I CMD=4 S PGRP=$P(STG,U,9),SET=$P(STG,U,2),FLD=$P(STG,U,8)
I SET,$L(FLD),PGRP
E Q
S GRP=PGRP_$E(FLD)
I CMD<4 S ^VEN(7.93,"AX",SET,GRP,IEN)="" Q
K ^VEN(7.93,"AX",SET,GRP,IEN)
Q
;
OSET(DEFEF) ; EP - RETURN SET IEN IF THE TEMPLATE IS ASSOCIATED WITH A SET
I '$G(DEFEF) Q 0
I '$O(^VEN(7.92,0)) Q 0
I '$O(^VEN(7.93,"AS",0)) Q 0
N OSET
S OSET=+$P($G(^VEN(7.41,+$G(DEFEF),0)),U,9)
Q OSET
;
TPC(DFN) ; EP-THIRD PARTY COVERAGE
I '$D(^DPT(DFN)) Q ""
N A,B,C,STG
S A=$$PVT(DFN),B=$$MCR(DFN),C=$$MCD(DFN),STG=""
I $L(A) S STG=A
I $L(STG),$L(B) S STG=A_", "_B
I '$L(A),$L(B) S STG=B
I $L(STG),$L(C) S STG=STG_", "_C
I '$L(STG),$L(C) S STG=C
S STG=$TR(STG,U,",")
Q STG
;
PVT(DFN) ; EP-PRIVATE INSURANCE
N TPIEN,IIEN,NAME,INO,D1,D2,%,STG,STATUS
S TPIEN=0,STG=""
F S TPIEN=$O(^AUPNPRVT(DFN,11,TPIEN)) Q:'TPIEN S %=$G(^AUPNPRVT(DFN,11,TPIEN,0)) I $L(%) D
. S IIEN=+%,INO=$P(%,U,2),D1=$P(%,U,6),D2=$P(%,U,7)
. S NAME=$P($G(^AUTNINS(IIEN,0)),U) I '$L(NAME) Q
. I D1,D1>DT Q
. I D2,D2<DT Q
. I $L(STG) S STG=STG_U
. S STG=STG_NAME_" ("_INO_")"
. S STATUS=$P($G(^AUTNINS(IIEN,1)),U,7)
. I STATUS>2 S STG=STG_$S(STATUS=3:" [UNVERIFIED]",STATUS=4:" [UNBILLABLE]",1:"")
. Q
Q STG
;
MCD(DFN) ; EP-MEDICAID ; SHOW EXPIRATION DATE IF MCD IS CURRENT
N %,Y,MIEN,DIEN,D1,D2,STG,MAXDT
S MIEN=999999999999,STG="",MAXDT=0
F S MIEN=$O(^AUPNMCD("B",DFN,MIEN),-1) Q:'MIEN S DIEN=9999999 F S DIEN=$O(^AUPNMCD(MIEN,11,DIEN),-1) Q:'DIEN D ; ALSO MANAGES DUPLICATE RECORDS PROPERLY
. S %=$G(^AUPNMCD(MIEN,11,DIEN,0)) I '$L(%) Q
. S D1=+%,D2=$P(%,U,2)
. I D1'>MAXDT Q ; ONLY CHECK THE LATEST RECORD
. S MAXDT=D1
. I D2 S Y=D2 X ^DD("DD")
. I D2,DT>D2 S STG="Medicaid expired "_Y Q
. I D2 S STG="Medicaid (expires "_Y_")" Q
. S STG="Medicaid (expires ??)"
. Q
Q STG ; STG WILL ALWAYS CONTAIN THE MCD STATUS FOR THE LATEST RECORD
;
MCR(DFN) ; EP-MEDICARE
N %,MIEN,DIEN,D1,D2
S MIEN=$O(^AUPNMCR("B",DFN,999999999),-1) I 'MIEN Q "" ; MANAGES DUPLICATE RECORDS PROPERLY
S DIEN=$O(^AUPNMCR(MIEN,11,999999999),-1) I 'DIEN Q ""
S %=$G(^AUPNMCR(MIEN,11,DIEN,0)) I '$L(%) Q ""
S D1=+%,D2=$P(%,U,2)
I D1,D1>DT Q ""
I D2,D2<DT Q ""
Q "Medicare"
;
SPEC(DFN,DEFEF) ; EP-GET DATA FOR OCXS
N CIEN,EIEN,MM,PCE,HIEN,HDR,TAG,VAL,X
S CIEN=0 F S CIEN=$O(^VEN(7.62,"AB",+$G(DEFEF),CIEN)) Q:'CIEN D
. S EIEN=0 F S EIEN=$O(^VEN(7.62,CIEN,3,"B",EIEN)) Q:'EIEN D
.. S TAG=$G(^VEN(7.61,EIEN,1)) I '$L(TAG) Q
.. S X=$G(^VEN(7.61,EIEN,0)) I X="" Q
.. S HIEN=$P(X,U,2) I 'HIEN Q
.. S PCE=$P(X,U,3) I 'PCE Q
.. S HDR=$P($G(^VEN(7.42,HIEN,0)),U) I HDR="" Q
.. X ("S VAL=$$"_TAG_"(DFN)")
.. S X=$G(SPECHOLD(HDR))
.. S $P(X,"\",PCE)=VAL
.. S SPECHOLD(HDR)=X
.. Q
. Q
Q
;
VENPCC1C ; IHS/OIT/GIS - MORE DATA MINING FOR ENCOUNTER FORMS 09 Mar 2004 8:15 AM ;
+1 ;;2.6;PCC+;;NOV 12, 2007
+2 ;
+3 ; ONLY THE x FIELDS ARE POPULTED HERE UNDER VER 2.5. NEW CODE IS IN VENPCCC
+4 ; ART PKG FOR ALLERGIES IS SUPPORTED HERE
+5 ;
XSET(SS,DFN,MIEN,MMF,CLASS,DEFEF) ; EP-SET MAIL MERGE FIELDS INTO TMP ARRAY
+1 NEW PTYPE,X,VAL,TAG,TMP
+2 SET PTYPE=$PIECE($GET(^VEN(SS,MIEN,0)),U,9)
+3 SET TMP=$NAME(^TMP("VEN PRNT",$JOB,1))
+4 ; FIELD FAILED TO MATCH PATIENT TYPE
IF '$$OK(SS,DFN,MIEN,PTYPE,CLASS,DEFEF)
QUIT 0
+5 SET X=^VEN(SS,MIEN,0)
+6 SET VAL=$PIECE(X,U)
+7 SET TAG=$GET(^VEN(SS,MIEN,1))
+8 ; COMPUTED VALUE ; TO PREVENT PROBLEMS CAUSED BY INVALID DATABASE ENTRY
IF TAG'=""
IF TAG?1.8UN1"^VENPCC"1.2UN
XECUTE "I $L($T("_TAG_"))"
IF $TEST
XECUTE ("N X S VAL=$$"_TAG_"(DFN)")
+9 IF SS=7.94
SET ^TMP("VEN PRNT",$JOB,1,MMF)=$PIECE(X,U,4)_VAL_$PIECE(X,U,5)
QUIT 1
+10 SET ^TMP("VEN PRNT",$JOB,1,MMF)=VAL
C1 ; CODE #1
SET %=$PIECE(X,U,6)
IF %'=""
SET @TMP@(MMF_"a")=%
C2 ; CODE #2
SET %=$PIECE(X,U,7)
IF %'=""
SET @TMP@(MMF_"b")=%
+1 QUIT 1
+2 ;
OK(SS,DFN,MIEN,PTYPE,CLASS,DEFEF) ; EP-CHECK FOR PATIENT TYPE MATCH
+1 NEW TAG,X,FORM
+2 IF PTYPE'=CLASS
QUIT 0
+3 SET TAG=$GET(^VEN(SS,MIEN,2))
IF TAG=""
QUIT 1
+4 XECUTE ("S X=$$"_TAG_"(DFN)")
+5 QUIT X
+6 ;
ALLERG(APCHSPAT) ; EP-ALLERGIES
+1 NEW APCHSDFN,IIEN,ICD,TOT,OK,MAX,APCHSP,APCHSNKA
+2 ; USE THE ADVERSE RXN TRACKING PKG, VER 2.5
IF $PIECE($GET(^VEN(7.5,$$CFG^VENPCCU,0)),U,23)
DO ART^VENPCC1L(APCHSPAT)
QUIT
+3 SET APCHSDFN=""
SET TOT=0
SET MAX=$PIECE($GET(^VEN(7.41,+$GET(DEFEF),2)),U,5)
IF 'MAX
SET MAX=5
+4 FOR
IF TOT=(MAX+1)
QUIT
SET APCHSDFN=$ORDER(^AUPNPROB("AC",+$GET(APCHSPAT),APCHSDFN))
IF 'APCHSDFN
QUIT
Begin DoDot:1
+5 SET IIEN=+$PIECE($GET(^AUPNPROB(APCHSDFN,0)),U)
+6 SET APCHSP=$PIECE($GET(^ICD9(IIEN,0)),U)
+7 IF $LENGTH(APCHSP)
SET APCHSNKA=0
DO PROBACHK^APCHS40
IF $TEST
IF 'APCHSNKA
DO SETA(APCHSDFN)
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
SETA(PIEN) ;
+1 NEW NARR,NIEN,MAXNARR
+2 ; MAX STG LENGTH
SET MAXNARR=$PIECE($GET(^VEN(7.41,$GET(DEFEF),14)),U,6)
IF 'MAXNARR
SET MAXNARR=32
+3 SET NIEN=+$PIECE($GET(^AUPNPROB(PIEN,0)),U,5)
+4 SET NARR=$PIECE($GET(^AUTNPOV(NIEN,0)),U)
+5 IF '$LENGTH(NARR)
QUIT
+6 SET TOT=TOT+1
+7 IF TOT=(MAX+1)
SET @TMP@(1,("a"_MAX))="More allergies on Hlth Summary!"
QUIT
+8 SET @TMP@(1,("a"_TOT))=$EXTRACT(NARR,1,MAXNARR)
+9 QUIT
+10 ;
INS(DFN) ; EP-- send the patient dfn and get back 3p elig
+1 QUIT $$TPC(DFN)
+2 ;
CLASS(DFN) ; EP-GIVEN THE DFN RETURN THE PATIENT CLASS FOR SITE PREFERENCES
+1 ; 1=INFANT,2=CHILD,3=ADULT MALE,4=ADULT FEMALE
+2 NEW AGE,SEX,DOB,X
+3 SET X=$PIECE($GET(^DPT(DFN,0)),U,2,3)
SET DOB=$PIECE(X,U,2)
SET SEX=$PIECE(X,U)
+4 IF DOB
IF $LENGTH(SEX)
+5 IF '$TEST
QUIT ""
+6 SET AGE=(DT-DOB)\10000
+7 SET X=$SELECT(AGE<2:1,AGE<13:2,SEX="M":3,1:4)
+8 QUIT X
+9 ;
IF ; EP-ENABLE IMMUNIZATION FORECASTING AT SITES THAT SUPPORT IMMUNIZATION FORECASTING
+1 ; FOR IMM PKG 8.0 ; PATCHED BY GIS/ITSC
IF $LENGTH($TEXT(VER^BILOGO))
IF $$VER^BILOGO>7.99
IF $LENGTH($TEXT(IMMBI^BIAPCHS))
NEW TMP,%
SET TMP="IMM"
SET %=$$NEWIMM^VENPCCS2(DFN)
KILL @TMP,%
QUIT
+2 NEW I,TOT,X,Y,Z,%,N,LINE,BIDE,IMM,GRP,DATE,PRE,POST,TMP
+3 SET TMP=$NAME(^TMP("VEN PRNT",$JOB,1))
+4 SET (LINE,PRE,POST)=""
SET TOT=7
+5 SET %=$ORDER(^VEN(7.94,"B","IMMUNIZATIONS",0))
IF %
SET PRE=$PIECE($GET(^VEN(7.94,%,0)),U,4)
SET POST=$PIECE($GET(^VEN(7.94,%,0)),U,5)
+6 FOR I=8,26,27,60,33,44,57
SET BIDE(I)=""
+7 DO IMMHX^BIRPC(.LINE,DFN,.BIDE)
+8 ; CLEAR OUT OLD VALUES FOR IMMUNIZATIONS
FOR I=9:1:25
SET @TMP@("h"_I)=""
+9 SET Z=$LENGTH(LINE,U)-1
+10 FOR N=1:1:Z
SET X=$PIECE(LINE,U,N)
IF $LENGTH(X)
Begin DoDot:1
+11 SET IMM=$PIECE(X,"|",2)
SET DATE=$PIECE(X,"|",8)
SET GRP=$PIECE(X,"|",4)
+12 IF $LENGTH(IMM)
IF $LENGTH(DATE)
IF $LENGTH(GRP)
+13 IF '$TEST
QUIT
+14 SET GRP(GRP)=PRE_IMM_" "_DATE_POST
+15 QUIT
End DoDot:1
+16 SET GRP=""
FOR TOT=9:1
SET GRP=$ORDER(GRP(GRP))
IF GRP=""
QUIT
SET @TMP@("h"_TOT)=GRP(GRP)
+17 QUIT
+18 ;
IX(X,CMD,IEN) ; EP-1=SET, 2=MMF, 3=DELETE
+1 IF $GET(X)=""
QUIT
+2 IF '$DATA(^VEN(7.93,+$GET(IEN),0))
QUIT
+3 IF +$GET(CMD)<1
IF +$GET(CMD)>4
QUIT
+4 NEW STG,MMF,SET,%
+5 SET STG=^VEN(7.93,IEN,0)
+6 IF CMD#2
SET SET=X
SET MMF=$PIECE($GET(^VEN(7.42,+$PIECE(STG,U,3),0)),U)
+7 IF '$TEST
SET MMF=$PIECE($GET(^VEN(7.42,X,0)),U)
SET SET=$PIECE(STG,U,2)
+8 IF 'SET!(MMF="")
QUIT
+9 IF CMD<3
SET ^VEN(7.93,"AS",SET,MMF,IEN)=""
QUIT
+10 KILL ^VEN(7.93,"AS",SET,MMF,IEN)
+11 QUIT
+12 ;
AX(X,CMD,IEN) ; EP-1=SET, 2=OGRP, 3=PGRP, 4=DELETE
+1 IF $GET(X)=""
QUIT
+2 IF '$DATA(^VEN(7.93,+$GET(IEN),0))
QUIT
+3 IF +$GET(CMD)<1
IF +$GET(CMD)>4
QUIT
+4 NEW STG,PGRP,SET,%,GRP,FLD
+5 SET STG=^VEN(7.93,IEN,0)
+6 IF CMD=1
SET SET=X
SET PGRP=$PIECE(STG,U,9)
SET FLD=$PIECE(STG,U,8)
+7 IF CMD=2
SET FLD=X
SET SET=$PIECE(STG,U,2)
SET PGRP=$PIECE(STG,U,9)
+8 IF CMD=3
SET PGRP=X
SET SET=$PIECE(STG,U,2)
SET FLD=$PIECE(STG,U,8)
+9 IF CMD=4
SET PGRP=$PIECE(STG,U,9)
SET SET=$PIECE(STG,U,2)
SET FLD=$PIECE(STG,U,8)
+10 IF SET
IF $LENGTH(FLD)
IF PGRP
+11 IF '$TEST
QUIT
+12 SET GRP=PGRP_$EXTRACT(FLD)
+13 IF CMD<4
SET ^VEN(7.93,"AX",SET,GRP,IEN)=""
QUIT
+14 KILL ^VEN(7.93,"AX",SET,GRP,IEN)
+15 QUIT
+16 ;
OSET(DEFEF) ; EP - RETURN SET IEN IF THE TEMPLATE IS ASSOCIATED WITH A SET
+1 IF '$GET(DEFEF)
QUIT 0
+2 IF '$ORDER(^VEN(7.92,0))
QUIT 0
+3 IF '$ORDER(^VEN(7.93,"AS",0))
QUIT 0
+4 NEW OSET
+5 SET OSET=+$PIECE($GET(^VEN(7.41,+$GET(DEFEF),0)),U,9)
+6 QUIT OSET
+7 ;
TPC(DFN) ; EP-THIRD PARTY COVERAGE
+1 IF '$DATA(^DPT(DFN))
QUIT ""
+2 NEW A,B,C,STG
+3 SET A=$$PVT(DFN)
SET B=$$MCR(DFN)
SET C=$$MCD(DFN)
SET STG=""
+4 IF $LENGTH(A)
SET STG=A
+5 IF $LENGTH(STG)
IF $LENGTH(B)
SET STG=A_", "_B
+6 IF '$LENGTH(A)
IF $LENGTH(B)
SET STG=B
+7 IF $LENGTH(STG)
IF $LENGTH(C)
SET STG=STG_", "_C
+8 IF '$LENGTH(STG)
IF $LENGTH(C)
SET STG=C
+9 SET STG=$TRANSLATE(STG,U,",")
+10 QUIT STG
+11 ;
PVT(DFN) ; EP-PRIVATE INSURANCE
+1 NEW TPIEN,IIEN,NAME,INO,D1,D2,%,STG,STATUS
+2 SET TPIEN=0
SET STG=""
+3 FOR
SET TPIEN=$ORDER(^AUPNPRVT(DFN,11,TPIEN))
IF 'TPIEN
QUIT
SET %=$GET(^AUPNPRVT(DFN,11,TPIEN,0))
IF $LENGTH(%)
Begin DoDot:1
+4 SET IIEN=+%
SET INO=$PIECE(%,U,2)
SET D1=$PIECE(%,U,6)
SET D2=$PIECE(%,U,7)
+5 SET NAME=$PIECE($GET(^AUTNINS(IIEN,0)),U)
IF '$LENGTH(NAME)
QUIT
+6 IF D1
IF D1>DT
QUIT
+7 IF D2
IF D2<DT
QUIT
+8 IF $LENGTH(STG)
SET STG=STG_U
+9 SET STG=STG_NAME_" ("_INO_")"
+10 SET STATUS=$PIECE($GET(^AUTNINS(IIEN,1)),U,7)
+11 IF STATUS>2
SET STG=STG_$SELECT(STATUS=3:" [UNVERIFIED]",STATUS=4:" [UNBILLABLE]",1:"")
+12 QUIT
End DoDot:1
+13 QUIT STG
+14 ;
MCD(DFN) ; EP-MEDICAID ; SHOW EXPIRATION DATE IF MCD IS CURRENT
+1 NEW %,Y,MIEN,DIEN,D1,D2,STG,MAXDT
+2 SET MIEN=999999999999
SET STG=""
SET MAXDT=0
+3 ; ALSO MANAGES DUPLICATE RECORDS PROPERLY
FOR
SET MIEN=$ORDER(^AUPNMCD("B",DFN,MIEN),-1)
IF 'MIEN
QUIT
SET DIEN=9999999
FOR
SET DIEN=$ORDER(^AUPNMCD(MIEN,11,DIEN),-1)
IF 'DIEN
QUIT
Begin DoDot:1
+4 SET %=$GET(^AUPNMCD(MIEN,11,DIEN,0))
IF '$LENGTH(%)
QUIT
+5 SET D1=+%
SET D2=$PIECE(%,U,2)
+6 ; ONLY CHECK THE LATEST RECORD
IF D1'>MAXDT
QUIT
+7 SET MAXDT=D1
+8 IF D2
SET Y=D2
XECUTE ^DD("DD")
+9 IF D2
IF DT>D2
SET STG="Medicaid expired "_Y
QUIT
+10 IF D2
SET STG="Medicaid (expires "_Y_")"
QUIT
+11 SET STG="Medicaid (expires ??)"
+12 QUIT
End DoDot:1
+13 ; STG WILL ALWAYS CONTAIN THE MCD STATUS FOR THE LATEST RECORD
QUIT STG
+14 ;
MCR(DFN) ; EP-MEDICARE
+1 NEW %,MIEN,DIEN,D1,D2
+2 ; MANAGES DUPLICATE RECORDS PROPERLY
SET MIEN=$ORDER(^AUPNMCR("B",DFN,999999999),-1)
IF 'MIEN
QUIT ""
+3 SET DIEN=$ORDER(^AUPNMCR(MIEN,11,999999999),-1)
IF 'DIEN
QUIT ""
+4 SET %=$GET(^AUPNMCR(MIEN,11,DIEN,0))
IF '$LENGTH(%)
QUIT ""
+5 SET D1=+%
SET D2=$PIECE(%,U,2)
+6 IF D1
IF D1>DT
QUIT ""
+7 IF D2
IF D2<DT
QUIT ""
+8 QUIT "Medicare"
+9 ;
SPEC(DFN,DEFEF) ; EP-GET DATA FOR OCXS
+1 NEW CIEN,EIEN,MM,PCE,HIEN,HDR,TAG,VAL,X
+2 SET CIEN=0
FOR
SET CIEN=$ORDER(^VEN(7.62,"AB",+$GET(DEFEF),CIEN))
IF 'CIEN
QUIT
Begin DoDot:1
+3 SET EIEN=0
FOR
SET EIEN=$ORDER(^VEN(7.62,CIEN,3,"B",EIEN))
IF 'EIEN
QUIT
Begin DoDot:2
+4 SET TAG=$GET(^VEN(7.61,EIEN,1))
IF '$LENGTH(TAG)
QUIT
+5 SET X=$GET(^VEN(7.61,EIEN,0))
IF X=""
QUIT
+6 SET HIEN=$PIECE(X,U,2)
IF 'HIEN
QUIT
+7 SET PCE=$PIECE(X,U,3)
IF 'PCE
QUIT
+8 SET HDR=$PIECE($GET(^VEN(7.42,HIEN,0)),U)
IF HDR=""
QUIT
+9 XECUTE ("S VAL=$$"_TAG_"(DFN)")
+10 SET X=$GET(SPECHOLD(HDR))
+11 SET $PIECE(X,"\",PCE)=VAL
+12 SET SPECHOLD(HDR)=X
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
