APCLV1 ; IHS/CMI/LAB - visit entry utilities/get codes ;
;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
;
;IHS/TUCSON/LAB - patch 1 modified subroutine FACTX to check
;for existence of AUTTLOC( node 3/4/97
;cmi/anch/maw 9/12/2007 code set versioning in EM
COMM ;EP ; get COMMUNITY - STATE,COUNTY,COMMUNITY codes
NEW Y,%,P,Z
S %=""
I '$D(^AUPNVSIT(V,0)) Q %
S P=$P(^AUPNVSIT(V,0),U,5)
I 'P Q %
I '$D(^AUPNPAT(P)) Q %
S Y=$O(^AUPNPAT(P,51,""),-1) I 'Y Q %
S Z=$P(^AUPNPAT(P,51,Y,0),U,3)
I 'Z S Z=$P($G(^AUPNPAT(P,11)),U,17)
I 'Z Q ""
Q $S($G(F)="E":$P(^AUTTCOM(Z,0),U),$G(F)="C":$P(^AUTTCOM(Z,0),U,8),1:Z)
;
CHART ;EP - returns ASUFAC_HRN ( 12 digits, HRN is left zero filled)
NEW L,%,C,S,P,Z
S %=""
I '$D(^AUPNVSIT(V,0)) Q %
S Z=^AUPNVSIT(V,0)
S P=$P(Z,U,5)
I 'P Q %
I $P(Z,U,6),$D(^AUPNPAT(P,41,$P(Z,U,6),0)) S L=$P(Z,U,6) S %=$$GETCHART(L) I %]"" Q %
I $G(DUZ(2)) S L=DUZ(2) S %=$$GETCHART(L)
I %="" S L=$O(^AUPNPAT(P,41,0)) I L S %=$$GETCHART(L)
I %="" S %=" ??????"
Q %
GETCHART(L) ;
S S=$P(^AUTTLOC(L,0),U,10)
I S="" Q S
S C=$P($G(^AUPNPAT(P,41,L,0)),U,2)
I C="" Q C
S C=$E("000000",1,6-$L(C))_C
S %=S_C
Q %
;
GETABBRV ;
LOCENC ;EP - given visit ien V, return loc. of encounter in format F
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U,6)
I Y="" Q Y
I '$D(^AUTTLOC(Y)) Q -1
Q $S($G(F)="E":$P(^DIC(4,Y,0),U),$G(F)="C":$P(^AUTTLOC(Y,0),U,10),1:Y)
;
VD ; EP - given visit ien in V, return date of visit in internal or external format
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U)
I Y="" Q Y
Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,"."))
;
VDTM ;EP - given visit ien in V, return visit date and time in F format
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U)
I Y="" Q Y
Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2"),$G(F)="E":$$FMTE^XLFDT(Y,"1"),1:Y)
;
TIME ;EP - given visit ien in V, returns visit time of day in format F
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U)
I Y="" Q Y
S Y=$S($G(F)="E":$$FMTE^XLFDT(Y,"2"),$G(F)="P":$$FMTE^XLFDT(Y,"2P"),1:Y)
I $G(F)="P" Q $P(Y," ",2,99)
I $G(F)="E" Q $P(Y,"@",2)
Q $P(Y,".",2)
;
LASTVD(P,F) ;PEP - given patient DFN in P, return pt's last pcc visit date,
; using the data fetcher. Returns date in format specified in F.
I '$G(P) Q ""
I $G(F)="" S F="I"
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW Y,ERR,LVD
S ERR=$$START1^APCLDF(P_"^LAST VISIT","LVD(")
I '$D(LVD(1)) Q "" ;IHS/CMI/LAB
S Y=$P(LVD(1),U)
Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,"."))
;
DOW ;EP - returns
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P($P(^AUPNVSIT(V,0),U),".")
I Y="" Q Y
Q $S($G(F)="E":$$DOW^XLFDT(Y),1:$$DOW^XLFDT(Y,1))
;
TYPE ;EP type of visit
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U,3)
Q $S(Y="":Y,$G(F)="E":$$EXTSET^XBFUNC(9000010,.03,Y),1:Y)
;
SC ;EP - service category
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U,7)
Q $S(Y="":Y,$G(F)="E":$$EXTSET^XBFUNC(9000010,.07,Y),1:Y)
;
CLINIC ;EP - clinic
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U,8)
I Y="" Q Y
I '$D(^DIC(40.7,Y)) Q -1
Q $S($G(F)="E":$P(^DIC(40.7,Y,0),U),$G(F)="C":$P(^DIC(40.7,Y,0),U,2),1:Y)
;
EM ;EP - eval&man cpt code
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U,17)
I Y="" Q Y
I '$D(^ICPT(Y)) Q -1
;Q $S($G(F)="E":$P(^ICPT(Y,0),U,2),$G(F)="C":$P(^ICPT(Y,0),U),1:Y) ;cmi/anch/maw 9/12/2007 orig line
Q $S($G(F)="E":$P($$CPT^ICPTCOD(Y),U,3),$G(F)="C":$P($$CPT^ICPTCOD(Y),U,2),1:Y) ;cmi/anch/maw 9/10/2007 csv
;
LS ;EP - level of service code
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U,19)
Q $S(Y="":Y,$G(F)="E":$$EXTSET^XBFUNC(9000010,.19,Y),1:Y)
;
NLAB ;EP - #labs
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW %,Y
S (Y,%)=0 F S Y=$O(^AUPNVLAB("AD",V,Y)) Q:Y'=+Y S %=%+1
Q %
NRX ;EP - #rxs
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW %,Y
S (Y,%)=0 F S Y=$O(^AUPNVMED("AD",V,Y)) Q:Y'=+Y S %=%+1
Q %
;
ADMSERV ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW %,Y,Z
S %="",Z=$O(^AUPNVINP("AD",V,0))
I 'Z Q %
S Y=$$VALI^XBDIQ1(9000010.02,Z,.04)
Q $S('Y:%,$G(F)="C":$P($G(^DIC(45.7,Y,9999999)),U),$G(F)="I":Y,$G(F)="E":$P(^DIC(45.7,Y,0),U),1:"")
DSCHSERV ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW %,Y,Z
S %="",Z=$O(^AUPNVINP("AD",V,0))
I 'Z Q %
S Y=$$VALI^XBDIQ1(9000010.02,Z,.05)
Q $S('Y:%,$G(F)="C":$P($G(^DIC(45.7,Y,9999999)),U),$G(F)="I":Y,$G(F)="E":$P(^DIC(45.7,Y,0),U),1:"")
ADMTYPE ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW %,Y,Z
S %="",Z=$O(^AUPNVINP("AD",V,0))
I 'Z Q %
S Y=$$VALI^XBDIQ1(9000010.02,Z,.07)
I $P(^DD(9000010.02,.07,0),U,2)[42.1 Q $S('Y:%,$G(F)="C":$P($G(^DIC(42.1,Y,9999999)),U),$G(F)="I":Y,$G(F)="E":$P(^DIC(42.1,Y,0),U),1:"")
I $P(^DD(9000010.02,.07,0),U,2)[405.1 Q $S('Y:%,$G(F)="C":$P($G(^DG(405.1,Y,"IHS")),U),$G(F)="I":Y,$G(F)="E":$P(^DG(405.1,Y,0),U),1:"")
Q ""
ADMUB ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW %,Y,Z
S %="",Z=$O(^AUPNVINP("AD",V,0))
I 'Z Q %
I $G(F)="C" Q $$VALI^XBDIQ1(9000010.02,Z,6101)
Q $$VAL^XBDIQ1(9000010.02,Z,6101)
ADMSOURC ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW %,Y,Z
S %="",Z=$O(^AUPNVINP("AD",V,0))
I 'Z Q %
I $G(F)="C" D Q Y
.S Y=$$VALI^XBDIQ1(9000010.02,Z,6102) I 'Y Q
.S Y=$$VAL^XBDIQ1(9999999.53,Y,.02)
Q $$VAL^XBDIQ1(9000010.02,Z,6102)
DSCHTYPE ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW %,Y,Z
S %="",Z=$O(^AUPNVINP("AD",V,0))
I 'Z Q %
S Y=$$VALI^XBDIQ1(9000010.02,Z,.06)
I $P(^DD(9000010.02,.06,0),U,2)[42.2 Q $S('Y:%,$G(F)="C":$P($G(^DIC(42.2,Y,9999999)),U),$G(F)="I":Y,$G(F)="E":$P(^DIC(42.2,Y,0),U),1:"")
I $P(^DD(9000010.02,.06,0),U,2)[405.1 Q $S('Y:%,$G(F)="C":$P($G(^DG(405.1,Y,"IHS")),U),$G(F)="I":Y,$G(F)="E":$P(^DG(405.1,Y,0),U),1:"")
Q ""
DSCHDATE ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y,Z
S Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q Z
S Y=$P(^AUPNVINP(Z,0),U)
I Y="" Q Y
Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,"."))
DDTM ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y,Z
S Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q Z
S Y=$P(^AUPNVINP(Z,0),U)
I Y="" Q Y
Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2"),$G(F)="E":$$FMTE^XLFDT(Y),1:Y)
CONSULTS ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y,Z
I $P(^AUPNVSIT(V,0),U,7)'="H" Q ""
S Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q Z
Q $P(^AUPNVINP(Z,0),U,8)
LOS ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y,Z,X,X1,X2
S Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q Z
S X1=$P($P(^AUPNVINP(Z,0),U),"."),X2=$P($P(^AUPNVSIT($P(^AUPNVINP(Z,0),U,3),0),U),".") D ^%DTC
S:X=0 X=1
Q X
FACTX ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW %,Y,Z
S %="",Z=$O(^AUPNVINP("AD",V,0))
I 'Z Q %
I F="I" Q $$VALI^XBDIQ1(9000010.02,Z,.09)
I F="C" S Y=$$VALI^XBDIQ1(9000010.02,Z,.09) S Y=+Y S Y=$S('Y:"",$D(^AUTTLOC(Y,0)):$P(^AUTTLOC(Y,0),U,10),1:"") Q Y ;IHS/TUCSON/LAB - patch1 changed this line to check for existence of AUTTLOC node 3/4/97
Q $$VAL^XBDIQ1(9000010.02,Z,.09)
ACTTIME ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$O(^AUPNVTM("AD",V,0))
I 'Y Q Y
Q $$VALI^XBDIQ1(9000010.19,Y,.01)
TRAVTIME ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$O(^AUPNVTM("AD",V,0))
I 'Y Q Y
Q $$VALI^XBDIQ1(9000010.19,Y,.04)
CHSCOST ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$O(^AUPNVCHS("AD",V,0))
I 'Y Q Y
Q $$VALI^XBDIQ1(9000010.03,Y,.06)
;
PATIENT ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U,5)
I Y="" Q Y
I '$D(^DPT(Y)) Q -1
Q $S($G(F)="E":$P(^DPT(Y,0),U),$G(F)="C":$$CHART^APCLV(V),1:Y)
;
DLM ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U,13)
I Y="" Q Y
Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,"."))
;
DVEX ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U,14)
I Y="" Q Y
Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,"."))
;
DWEX ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P($G(^AUPNVSIT(V,11)),U,6)
I Y="" Q Y
Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,"."))
;
APWI ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U,16)
Q $S(Y="":Y,$G(F)="E":$$EXTSET^XBFUNC(9000010,.16,Y),1:Y)
;
CODT ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U,18)
I Y="" Q Y
Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,"."))
;
APDT ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
S Y=$P(^AUPNVSIT(V,0),U,25)
I Y="" Q Y
Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,"."))
OUTSL ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
NEW Y
Q $P($G(^AUPNVSIT(V,21)),U)
;
PCHART ;EP
NEW %,C,S,Z
S %=""
I '$D(^AUPNPAT(P,0)) Q %
I 'L Q %
I '$D(^AUPNPAT(P,41,L,0)) Q %
S %=$$GETCHART(L)
I %="" S %=" ??????"
S %=$P(^AUTTLOC(L,0),U,7)_$E(%,7,12)
Q %
;
APCWL ;EP
I $G(V)="" Q ""
I '$D(^AUPNVSIT(V)) Q ""
NEW R,L,P,C S R=^AUPNVSIT(V,0)
I $P(R,U,11) Q "" ;deleted visit
I '$P(R,U,9) Q "" ;no dep entries
I '$D(^AUPNVPOV("AD",V)) Q "" ;no pov's
I '$D(^AUPNVPRV("AD",V)) Q "" ; no provider
I $P(R,U,3)="" Q ""
I $P(R,U,7)="" Q ""
I "AOS"'[$P(R,U,7) Q "" ;no A, O S
I "CVS"[$P(R,U,3) Q "" ;no contract, state or VA
S P=$P(R,U,5)
I 'P Q "" ;no patient
I '$D(^DPT(P,0)) Q "" ;no patient
I $P(^DPT(P,0),U)["DEMO,PATIENT" Q "" ;no demo,patient visits
S L=$P(R,U,6)
I L="" Q "" ;no location
I '$D(^AUTTLOC(L,0)) Q "" ;location invalid
;check clinic
N CL ;cmi/anch/maw 8/7/2007
S C=$P(R,U,8) ;cmi/anch/maw 8/7/2007 split line here for dental mod
S CL=$S(C:$P(^DIC(40.7,C,0),U,2),1:25) ;if no clinic make it other
I CL=56,$D(^AUPNVMED("AD",V)) Q 1 ;dental visit with med
I C,$P($G(^DIC(40.7,C,90000)),U)'="Y" Q "" ;cmi/anch/maw 8/7/2007 moved this line and modified from split line
;I $T(@C)]"" Q "" ;not a workload reportable clinic code
S D=$$PRIMPROV^APCLV(V,"F") ;get internal of prov disc
I D="" Q ""
I '$D(^DIC(7,D,9999999)) Q "" ;can't check discipline
I $P($G(^DIC(7,D,9999999)),U,5)="Y" Q 1
Q ""
CLEX ;
09 ;;
11 ;;
36 ;;
41 ;;
42 ;;
51 ;;
52 ;;
53 ;;
54 ;;
60 ;;
99 ;;
APCLV1 ; IHS/CMI/LAB - visit entry utilities/get codes ;
+1 ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
+2 ;
+3 ;IHS/TUCSON/LAB - patch 1 modified subroutine FACTX to check
+4 ;for existence of AUTTLOC( node 3/4/97
+5 ;cmi/anch/maw 9/12/2007 code set versioning in EM
COMM ;EP ; get COMMUNITY - STATE,COUNTY,COMMUNITY codes
+1 NEW Y,%,P,Z
+2 SET %=""
+3 IF '$DATA(^AUPNVSIT(V,0))
QUIT %
+4 SET P=$PIECE(^AUPNVSIT(V,0),U,5)
+5 IF 'P
QUIT %
+6 IF '$DATA(^AUPNPAT(P))
QUIT %
+7 SET Y=$ORDER(^AUPNPAT(P,51,""),-1)
IF 'Y
QUIT %
+8 SET Z=$PIECE(^AUPNPAT(P,51,Y,0),U,3)
+9 IF 'Z
SET Z=$PIECE($GET(^AUPNPAT(P,11)),U,17)
+10 IF 'Z
QUIT ""
+11 QUIT $SELECT($GET(F)="E":$PIECE(^AUTTCOM(Z,0),U),$GET(F)="C":$PIECE(^AUTTCOM(Z,0),U,8),1:Z)
+12 ;
CHART ;EP - returns ASUFAC_HRN ( 12 digits, HRN is left zero filled)
+1 NEW L,%,C,S,P,Z
+2 SET %=""
+3 IF '$DATA(^AUPNVSIT(V,0))
QUIT %
+4 SET Z=^AUPNVSIT(V,0)
+5 SET P=$PIECE(Z,U,5)
+6 IF 'P
QUIT %
+7 IF $PIECE(Z,U,6)
IF $DATA(^AUPNPAT(P,41,$PIECE(Z,U,6),0))
SET L=$PIECE(Z,U,6)
SET %=$$GETCHART(L)
IF %]""
QUIT %
+8 IF $GET(DUZ(2))
SET L=DUZ(2)
SET %=$$GETCHART(L)
+9 IF %=""
SET L=$ORDER(^AUPNPAT(P,41,0))
IF L
SET %=$$GETCHART(L)
+10 IF %=""
SET %=" ??????"
+11 QUIT %
GETCHART(L) ;
+1 SET S=$PIECE(^AUTTLOC(L,0),U,10)
+2 IF S=""
QUIT S
+3 SET C=$PIECE($GET(^AUPNPAT(P,41,L,0)),U,2)
+4 IF C=""
QUIT C
+5 SET C=$EXTRACT("000000",1,6-$LENGTH(C))_C
+6 SET %=S_C
+7 QUIT %
+8 ;
GETABBRV ;
LOCENC ;EP - given visit ien V, return loc. of encounter in format F
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U,6)
+5 IF Y=""
QUIT Y
+6 IF '$DATA(^AUTTLOC(Y))
QUIT -1
+7 QUIT $SELECT($GET(F)="E":$PIECE(^DIC(4,Y,0),U),$GET(F)="C":$PIECE(^AUTTLOC(Y,0),U,10),1:Y)
+8 ;
VD ; EP - given visit ien in V, return date of visit in internal or external format
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U)
+5 IF Y=""
QUIT Y
+6 QUIT $SELECT($GET(F)="S":$$FMTE^XLFDT(Y,"2D"),$GET(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$PIECE(Y,"."))
+7 ;
VDTM ;EP - given visit ien in V, return visit date and time in F format
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U)
+5 IF Y=""
QUIT Y
+6 QUIT $SELECT($GET(F)="S":$$FMTE^XLFDT(Y,"2"),$GET(F)="E":$$FMTE^XLFDT(Y,"1"),1:Y)
+7 ;
TIME ;EP - given visit ien in V, returns visit time of day in format F
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U)
+5 IF Y=""
QUIT Y
+6 SET Y=$SELECT($GET(F)="E":$$FMTE^XLFDT(Y,"2"),$GET(F)="P":$$FMTE^XLFDT(Y,"2P"),1:Y)
+7 IF $GET(F)="P"
QUIT $PIECE(Y," ",2,99)
+8 IF $GET(F)="E"
QUIT $PIECE(Y,"@",2)
+9 QUIT $PIECE(Y,".",2)
+10 ;
LASTVD(P,F) ;PEP - given patient DFN in P, return pt's last pcc visit date,
+1 ; using the data fetcher. Returns date in format specified in F.
+2 IF '$GET(P)
QUIT ""
+3 IF $GET(F)=""
SET F="I"
+4 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+5 NEW Y,ERR,LVD
+6 SET ERR=$$START1^APCLDF(P_"^LAST VISIT","LVD(")
+7 ;IHS/CMI/LAB
IF '$DATA(LVD(1))
QUIT ""
+8 SET Y=$PIECE(LVD(1),U)
+9 QUIT $SELECT($GET(F)="S":$$FMTE^XLFDT(Y,"2D"),$GET(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$PIECE(Y,"."))
+10 ;
DOW ;EP - returns
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+5 IF Y=""
QUIT Y
+6 QUIT $SELECT($GET(F)="E":$$DOW^XLFDT(Y),1:$$DOW^XLFDT(Y,1))
+7 ;
TYPE ;EP type of visit
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U,3)
+5 QUIT $SELECT(Y="":Y,$GET(F)="E":$$EXTSET^XBFUNC(9000010,.03,Y),1:Y)
+6 ;
SC ;EP - service category
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U,7)
+5 QUIT $SELECT(Y="":Y,$GET(F)="E":$$EXTSET^XBFUNC(9000010,.07,Y),1:Y)
+6 ;
CLINIC ;EP - clinic
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U,8)
+5 IF Y=""
QUIT Y
+6 IF '$DATA(^DIC(40.7,Y))
QUIT -1
+7 QUIT $SELECT($GET(F)="E":$PIECE(^DIC(40.7,Y,0),U),$GET(F)="C":$PIECE(^DIC(40.7,Y,0),U,2),1:Y)
+8 ;
EM ;EP - eval&man cpt code
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U,17)
+5 IF Y=""
QUIT Y
+6 IF '$DATA(^ICPT(Y))
QUIT -1
+7 ;Q $S($G(F)="E":$P(^ICPT(Y,0),U,2),$G(F)="C":$P(^ICPT(Y,0),U),1:Y) ;cmi/anch/maw 9/12/2007 orig line
+8 ;cmi/anch/maw 9/10/2007 csv
QUIT $SELECT($GET(F)="E":$PIECE($$CPT^ICPTCOD(Y),U,3),$GET(F)="C":$PIECE($$CPT^ICPTCOD(Y),U,2),1:Y)
+9 ;
LS ;EP - level of service code
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U,19)
+5 QUIT $SELECT(Y="":Y,$GET(F)="E":$$EXTSET^XBFUNC(9000010,.19,Y),1:Y)
+6 ;
NLAB ;EP - #labs
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW %,Y
+4 SET (Y,%)=0
FOR
SET Y=$ORDER(^AUPNVLAB("AD",V,Y))
IF Y'=+Y
QUIT
SET %=%+1
+5 QUIT %
NRX ;EP - #rxs
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW %,Y
+4 SET (Y,%)=0
FOR
SET Y=$ORDER(^AUPNVMED("AD",V,Y))
IF Y'=+Y
QUIT
SET %=%+1
+5 QUIT %
+6 ;
ADMSERV ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW %,Y,Z
+4 SET %=""
SET Z=$ORDER(^AUPNVINP("AD",V,0))
+5 IF 'Z
QUIT %
+6 SET Y=$$VALI^XBDIQ1(9000010.02,Z,.04)
+7 QUIT $SELECT('Y:%,$GET(F)="C":$PIECE($GET(^DIC(45.7,Y,9999999)),U),$GET(F)="I":Y,$GET(F)="E":$PIECE(^DIC(45.7,Y,0),U),1:"")
DSCHSERV ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW %,Y,Z
+4 SET %=""
SET Z=$ORDER(^AUPNVINP("AD",V,0))
+5 IF 'Z
QUIT %
+6 SET Y=$$VALI^XBDIQ1(9000010.02,Z,.05)
+7 QUIT $SELECT('Y:%,$GET(F)="C":$PIECE($GET(^DIC(45.7,Y,9999999)),U),$GET(F)="I":Y,$GET(F)="E":$PIECE(^DIC(45.7,Y,0),U),1:"")
ADMTYPE ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW %,Y,Z
+4 SET %=""
SET Z=$ORDER(^AUPNVINP("AD",V,0))
+5 IF 'Z
QUIT %
+6 SET Y=$$VALI^XBDIQ1(9000010.02,Z,.07)
+7 IF $PIECE(^DD(9000010.02,.07,0),U,2)[42.1
QUIT $SELECT('Y:%,$GET(F)="C":$PIECE($GET(^DIC(42.1,Y,9999999)),U),$GET(F)="I":Y,$GET(F)="E":$PIECE(^DIC(42.1,Y,0),U),1:"")
+8 IF $PIECE(^DD(9000010.02,.07,0),U,2)[405.1
QUIT $SELECT('Y:%,$GET(F)="C":$PIECE($GET(^DG(405.1,Y,"IHS")),U),$GET(F)="I":Y,$GET(F)="E":$PIECE(^DG(405.1,Y,0),U),1:"")
+9 QUIT ""
ADMUB ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW %,Y,Z
+4 SET %=""
SET Z=$ORDER(^AUPNVINP("AD",V,0))
+5 IF 'Z
QUIT %
+6 IF $GET(F)="C"
QUIT $$VALI^XBDIQ1(9000010.02,Z,6101)
+7 QUIT $$VAL^XBDIQ1(9000010.02,Z,6101)
ADMSOURC ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW %,Y,Z
+4 SET %=""
SET Z=$ORDER(^AUPNVINP("AD",V,0))
+5 IF 'Z
QUIT %
+6 IF $GET(F)="C"
Begin DoDot:1
+7 SET Y=$$VALI^XBDIQ1(9000010.02,Z,6102)
IF 'Y
QUIT
+8 SET Y=$$VAL^XBDIQ1(9999999.53,Y,.02)
End DoDot:1
QUIT Y
+9 QUIT $$VAL^XBDIQ1(9000010.02,Z,6102)
DSCHTYPE ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW %,Y,Z
+4 SET %=""
SET Z=$ORDER(^AUPNVINP("AD",V,0))
+5 IF 'Z
QUIT %
+6 SET Y=$$VALI^XBDIQ1(9000010.02,Z,.06)
+7 IF $PIECE(^DD(9000010.02,.06,0),U,2)[42.2
QUIT $SELECT('Y:%,$GET(F)="C":$PIECE($GET(^DIC(42.2,Y,9999999)),U),$GET(F)="I":Y,$GET(F)="E":$PIECE(^DIC(42.2,Y,0),U),1:"")
+8 IF $PIECE(^DD(9000010.02,.06,0),U,2)[405.1
QUIT $SELECT('Y:%,$GET(F)="C":$PIECE($GET(^DG(405.1,Y,"IHS")),U),$GET(F)="I":Y,$GET(F)="E":$PIECE(^DG(405.1,Y,0),U),1:"")
+9 QUIT ""
DSCHDATE ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y,Z
+4 SET Z=$ORDER(^AUPNVINP("AD",V,0))
IF 'Z
QUIT Z
+5 SET Y=$PIECE(^AUPNVINP(Z,0),U)
+6 IF Y=""
QUIT Y
+7 QUIT $SELECT($GET(F)="S":$$FMTE^XLFDT(Y,"2D"),$GET(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$PIECE(Y,"."))
DDTM ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y,Z
+4 SET Z=$ORDER(^AUPNVINP("AD",V,0))
IF 'Z
QUIT Z
+5 SET Y=$PIECE(^AUPNVINP(Z,0),U)
+6 IF Y=""
QUIT Y
+7 QUIT $SELECT($GET(F)="S":$$FMTE^XLFDT(Y,"2"),$GET(F)="E":$$FMTE^XLFDT(Y),1:Y)
CONSULTS ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y,Z
+4 IF $PIECE(^AUPNVSIT(V,0),U,7)'="H"
QUIT ""
+5 SET Z=$ORDER(^AUPNVINP("AD",V,0))
IF 'Z
QUIT Z
+6 QUIT $PIECE(^AUPNVINP(Z,0),U,8)
LOS ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y,Z,X,X1,X2
+4 SET Z=$ORDER(^AUPNVINP("AD",V,0))
IF 'Z
QUIT Z
+5 SET X1=$PIECE($PIECE(^AUPNVINP(Z,0),U),".")
SET X2=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVINP(Z,0),U,3),0),U),".")
DO ^%DTC
+6 IF X=0
SET X=1
+7 QUIT X
FACTX ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW %,Y,Z
+4 SET %=""
SET Z=$ORDER(^AUPNVINP("AD",V,0))
+5 IF 'Z
QUIT %
+6 IF F="I"
QUIT $$VALI^XBDIQ1(9000010.02,Z,.09)
+7 ;IHS/TUCSON/LAB - patch1 changed this line to check for existence of AUTTLOC node 3/4/97
IF F="C"
SET Y=$$VALI^XBDIQ1(9000010.02,Z,.09)
SET Y=+Y
SET Y=$SELECT('Y:"",$DATA(^AUTTLOC(Y,0)):$PIECE(^AUTTLOC(Y,0),U,10),1:"")
QUIT Y
+8 QUIT $$VAL^XBDIQ1(9000010.02,Z,.09)
ACTTIME ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$ORDER(^AUPNVTM("AD",V,0))
+5 IF 'Y
QUIT Y
+6 QUIT $$VALI^XBDIQ1(9000010.19,Y,.01)
TRAVTIME ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$ORDER(^AUPNVTM("AD",V,0))
+5 IF 'Y
QUIT Y
+6 QUIT $$VALI^XBDIQ1(9000010.19,Y,.04)
CHSCOST ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$ORDER(^AUPNVCHS("AD",V,0))
+5 IF 'Y
QUIT Y
+6 QUIT $$VALI^XBDIQ1(9000010.03,Y,.06)
+7 ;
PATIENT ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U,5)
+5 IF Y=""
QUIT Y
+6 IF '$DATA(^DPT(Y))
QUIT -1
+7 QUIT $SELECT($GET(F)="E":$PIECE(^DPT(Y,0),U),$GET(F)="C":$$CHART^APCLV(V),1:Y)
+8 ;
DLM ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U,13)
+5 IF Y=""
QUIT Y
+6 QUIT $SELECT($GET(F)="S":$$FMTE^XLFDT(Y,"2D"),$GET(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$PIECE(Y,"."))
+7 ;
DVEX ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U,14)
+5 IF Y=""
QUIT Y
+6 QUIT $SELECT($GET(F)="S":$$FMTE^XLFDT(Y,"2D"),$GET(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$PIECE(Y,"."))
+7 ;
DWEX ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE($GET(^AUPNVSIT(V,11)),U,6)
+5 IF Y=""
QUIT Y
+6 QUIT $SELECT($GET(F)="S":$$FMTE^XLFDT(Y,"2D"),$GET(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$PIECE(Y,"."))
+7 ;
APWI ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U,16)
+5 QUIT $SELECT(Y="":Y,$GET(F)="E":$$EXTSET^XBFUNC(9000010,.16,Y),1:Y)
+6 ;
CODT ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U,18)
+5 IF Y=""
QUIT Y
+6 QUIT $SELECT($GET(F)="S":$$FMTE^XLFDT(Y,"2D"),$GET(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$PIECE(Y,"."))
+7 ;
APDT ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 SET Y=$PIECE(^AUPNVSIT(V,0),U,25)
+5 IF Y=""
QUIT Y
+6 QUIT $SELECT($GET(F)="S":$$FMTE^XLFDT(Y,"2D"),$GET(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$PIECE(Y,"."))
OUTSL ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 NEW Y
+4 QUIT $PIECE($GET(^AUPNVSIT(V,21)),U)
+5 ;
PCHART ;EP
+1 NEW %,C,S,Z
+2 SET %=""
+3 IF '$DATA(^AUPNPAT(P,0))
QUIT %
+4 IF 'L
QUIT %
+5 IF '$DATA(^AUPNPAT(P,41,L,0))
QUIT %
+6 SET %=$$GETCHART(L)
+7 IF %=""
SET %=" ??????"
+8 SET %=$PIECE(^AUTTLOC(L,0),U,7)_$EXTRACT(%,7,12)
+9 QUIT %
+10 ;
APCWL ;EP
+1 IF $GET(V)=""
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 NEW R,L,P,C
SET R=^AUPNVSIT(V,0)
+4 ;deleted visit
IF $PIECE(R,U,11)
QUIT ""
+5 ;no dep entries
IF '$PIECE(R,U,9)
QUIT ""
+6 ;no pov's
IF '$DATA(^AUPNVPOV("AD",V))
QUIT ""
+7 ; no provider
IF '$DATA(^AUPNVPRV("AD",V))
QUIT ""
+8 IF $PIECE(R,U,3)=""
QUIT ""
+9 IF $PIECE(R,U,7)=""
QUIT ""
+10 ;no A, O S
IF "AOS"'[$PIECE(R,U,7)
QUIT ""
+11 ;no contract, state or VA
IF "CVS"[$PIECE(R,U,3)
QUIT ""
+12 SET P=$PIECE(R,U,5)
+13 ;no patient
IF 'P
QUIT ""
+14 ;no patient
IF '$DATA(^DPT(P,0))
QUIT ""
+15 ;no demo,patient visits
IF $PIECE(^DPT(P,0),U)["DEMO,PATIENT"
QUIT ""
+16 SET L=$PIECE(R,U,6)
+17 ;no location
IF L=""
QUIT ""
+18 ;location invalid
IF '$DATA(^AUTTLOC(L,0))
QUIT ""
+19 ;check clinic
+20 ;cmi/anch/maw 8/7/2007
NEW CL
+21 ;cmi/anch/maw 8/7/2007 split line here for dental mod
SET C=$PIECE(R,U,8)
+22 ;if no clinic make it other
SET CL=$SELECT(C:$PIECE(^DIC(40.7,C,0),U,2),1:25)
+23 ;dental visit with med
IF CL=56
IF $DATA(^AUPNVMED("AD",V))
QUIT 1
+24 ;cmi/anch/maw 8/7/2007 moved this line and modified from split line
IF C
IF $PIECE($GET(^DIC(40.7,C,90000)),U)'="Y"
QUIT ""
+25 ;I $T(@C)]"" Q "" ;not a workload reportable clinic code
+26 ;get internal of prov disc
SET D=$$PRIMPROV^APCLV(V,"F")
+27 IF D=""
QUIT ""
+28 ;can't check discipline
IF '$DATA(^DIC(7,D,9999999))
QUIT ""
+29 IF $PIECE($GET(^DIC(7,D,9999999)),U,5)="Y"
QUIT 1
+30 QUIT ""
CLEX ;
09 ;;
11 ;;
36 ;;
41 ;;
42 ;;
51 ;;
52 ;;
53 ;;
54 ;;
60 ;;
99 ;;
