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

BGPDU.m

Go to the documentation of this file. 
  1. BGPDU ; IHS/CMI/LAB - gpra utility calls ;
  1.  ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
  1.  ;
  1.  ;
  1. WH(P,BDATE,EDATE,T,F) ;EP
  1.  I '$G(P) Q ""
  1.  I '$G(T) Q ""
  1.  I '$G(F) S F=1
  1.  I $G(EDATE)="" Q ""
  1.  I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
  1.  ;go through procedures in a date range for this patient, check proc type
  1.  NEW D,X,Y,G,V
  1.  S (G,V)=0 F  S V=$O(^BWPCD("C",P,V)) Q:V=""!(G)  D
  1.  .Q:'$D(^BWPCD(V,0))
  1.  .I $P(^BWPCD(V,0),U,4)'=T Q
  1.  .S D=$P(^BWPCD(V,0),U,12)
  1.  .Q:D<BDATE
  1.  .Q:D>EDATE
  1.  .S G=V
  1.  .Q
  1.  I 'G Q ""
  1.  I F=1 Q $S(G:1,1:"")
  1.  I F=2 Q G
  1.  I F=3 S D=$P(^BWPCD(G,0),U,12) Q D
  1.  I F=4 S D=$P(^BWPCD(G,0),U,12) Q $$FMTE^XLFDT(D)
  1.  Q ""
  1. PLCODE(P,A) ;EP
  1.  I $G(P)="" Q ""
  1.  I $G(A)="" Q ""
  1.  N T
  1.  ;S T=$O(^ICD9("AB",A,0))
  1.  S T=+$$CODEN^ICDCODE(A,80)
  1.  I 'T Q ""
  1.  N X,Y,I S (X,Y,I)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I)  I $D(^AUPNPROB(X,0)) S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXCHK(Y,T,9) S I=1
  1.  Q I
  1. PLTAX(P,A) ;EP - is DX on problem list 1 or 0
  1.  I $G(P)="" Q ""
  1.  I $G(A)="" Q ""
  1.  N T S T=$O(^ATXAX("B",A,0))
  1.  I 'T Q ""
  1.  N X,Y,I S (X,Y,I)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I)  I $D(^AUPNPROB(X,0)) S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXCHK(Y,T,9) S I=1
  1.  Q I
  1. CPT(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT
  1.  I '$G(P) Q ""
  1.  I '$G(T) Q ""
  1.  I '$G(F) S F=1
  1.  I $G(EDATE)="" Q ""
  1.  I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
  1.  ;go through visits in a date range for this patient, check cpts
  1.  NEW D,BD,ED,X,Y,D,G,V
  1.  S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
  1.  F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G)  D
  1.  ..Q:'$D(^AUPNVSIT(V,0))
  1.  ..Q:'$D(^AUPNVCPT("AD",V))
  1.  ..S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G)  D
  1.  ...I $$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),T,1) S G=X
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  I 'G Q ""
  1.  I F=1 Q $S(G:1,1:"")
  1.  I F=2 Q G
  1.  I F=3 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  I F=4 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
  1.  I F=5 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVCPT(G,0),U)),U,2)
  1.  I F=6 S V=$P(^AUPNVCPT(G,0),U,3) I V Q 1_"^"_$P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVCPT(G,0),U)),U,2)_"^"_G
  1.  Q ""
  1. RAD(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT
  1.  I '$G(P) Q ""
  1.  I '$G(T) Q ""
  1.  I '$G(F) S F=1
  1.  I $G(EDATE)="" Q ""
  1.  I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
  1.  ;go through visits in a date range for this patient, check cpts
  1.  NEW D,BD,ED,X,Y,D,G,V,C
  1.  S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
  1.  F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G)  D
  1.  ..Q:'$D(^AUPNVSIT(V,0))
  1.  ..Q:'$D(^AUPNVRAD("AD",V))
  1.  ..S X=0 F  S X=$O(^AUPNVRAD("AD",V,X)) Q:X'=+X!(G)  D
  1.  ...S C=$P(^AUPNVRAD(X,0),U) Q:C=""  S C=$P($G(^RAMIS(71,C,0)),U,9) Q:C=""
  1.  ...I $$ICD^ATXCHK(C,T,1) S G=X
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  I 'G Q ""
  1.  I F=1 Q $S(G:1,1:"")
  1.  I F=2 Q G
  1.  I F=3 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  I F=4 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
  1.  I F=5 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P(^RAMIS(71,$P(^AUPNVRAD(G,0),U),0),U,9)
  1.  Q ""
  1. CPTI(P,BDATE,EDATE,CPTI) ;EP - did patient have this cpt (ien) in date range
  1.  I '$G(P) Q ""
  1.  I $G(CPTI)="" Q ""
  1.  I $G(BDATE)="" Q ""
  1.  I $G(EDATE)="" Q ""
  1.  I '$D(^ICPT(CPTI)) Q ""
  1.  I '$D(^AUPNVCPT("AA",P)) Q ""  ;no cpts for this patient
  1.  NEW D,BD,ED,X,Y,D,G,V
  1.  S ED=9999999-EDATE-1,BD=9999999-BDATE,G=""
  1.  F  S ED=$O(^AUPNVCPT("AA",P,CPTI,ED)) Q:ED=""!($P(ED,".")>BD)!(G)  S G="1"_"^"_(9999999-ED)
  1.  Q G
  1.  ;
  1. V ; GET VERSION
  1.  S BGP("VERSION")="2.0  January, 2003"
  1.  S BGPTEXT="TEXT",BGPLINE=3 G PRINT
  1.  F BGPJ=1:1 S BGPX=$T(@BGPTEXT+BGPJ),BGPX=$P(BGPX,";;",2) Q:BGPX="QUIT"!(BGPX="")  S BGPLINE=BGPJ
  1. PRINT W:$D(IOF) @IOF
  1.  F BGPJ=1:1:BGPLINE S BGPX=$T(@BGPTEXT+BGPJ),BGPX=$P(BGPX,";;",2) W !?80-$L(BGPX)\2,BGPX K BGPX
  1.  W !?80-(8+$L(BGP("VERSION")))/2,"Version ",BGP("VERSION")
  1. SITE G XIT:'$D(DUZ(2)) G:'DUZ(2) XIT S BGP("SITE")=$P(^DIC(4,DUZ(2),0),"^") W !!?80-$L(BGP("SITE"))\2,BGP("SITE")
  1. XIT ;
  1.  K BGPJ,BGPX,BGPTEXT,BGPLINE,BGP("SITE"),BGP("VERSION")
  1.  Q
  1. TEXT ;
  1.  ;;*******************************************************
  1.  ;;** Indian Health Service GPRA Data Reporting System  **
  1.  ;;*******************************************************
  1.  ;;QUIT
  1. BECPTS ;;
  1.  ;;74270
  1.  ;;74275
  1.  ;;74280
  1.  ;;
  1. SIGCPTS ;;
  1.  ;;45300
  1.  ;;45303
  1.  ;;45305
  1.  ;;45307
  1.  ;;45308
  1.  ;;45309
  1.  ;;45315
  1.  ;;45317
  1.  ;;45320
  1.  ;;45321
  1.  ;;45327
  1.  ;;45330
  1.  ;;45331
  1.  ;;45332
  1.  ;;45333
  1.  ;;45334
  1.  ;;45336
  1.  ;;45337
  1.  ;;45338
  1.  ;;45339
  1.  ;;45341
  1.  ;;45342
  1.  ;;45345
  1.  ;;
  1. COLOCPTS ;;
  1.  ;;45355
  1.  ;;45360
  1.  ;;45361
  1.  ;;45362
  1.  ;;45363
  1.  ;;45364
  1.  ;;45365
  1.  ;;45366
  1.  ;;45367
  1.  ;;45368
  1.  ;;45369
  1.  ;;45370
  1.  ;;45371
  1.  ;;45372
  1.  ;;45378
  1.  ;;45379
  1.  ;;45380
  1.  ;;45382
  1.  ;;45383
  1.  ;;45384
  1.  ;;45385
  1.  ;;45387
  1.  ;;