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

BGP4DU.m

Go to the documentation of this file. 
  1. BGP4DU ; IHS/CMI/LAB - gpra utility calls ;
  1.  ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
  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,O
  1.  S (G,V)=0,I="" F  S V=$O(^BWPCD("C",P,V)) Q:V=""  D
  1.  .Q:'$D(^BWPCD(V,0))
  1.  .I $P(^BWPCD(V,0),U,4)'=T Q
  1.  .Q:$$UP^XLFSTR($$VAL^XBDIQ1(9002086.1,V,.05))="ERROR/DISREGARD"
  1.  .S D=$P(^BWPCD(V,0),U,12)
  1.  .Q:D<BDATE
  1.  .Q:D>EDATE
  1.  .S I=$O(G(0)) I I>D Q
  1.  .S G=V,G(D)=""
  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^BGP4UTL2(A,80)
  1.  I T'>0 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)),$P(^AUPNPROB(X,0),U,12)'="D",$P(^AUPNPROB(X,0),U,12)'="I" S Y=$P(^AUPNPROB(X,0),U) I Y=T 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)),$P(^AUPNPROB(X,0),U,12)'="D",$P(^AUPNPROB(X,0),U,12)'="I" S Y=$P(^AUPNPROB(X,0),U) I $$ICD^BGP4UTL2(Y,T,9) S I=1
  1.  Q I
  1. CPT(P,BDATE,EDATE,T,F,SCEX) ;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.  S SCEX=$G(SCEX)
  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.  ..I SCEX]"",SCEX[$P(^AUPNVSIT(V,0),U,7) Q
  1.  ..S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G)  D
  1.  ...I $$ICD^BGP4UTL2($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^BGP4UTL2(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.  I F=6 S V=$P(^AUPNVRAD(G,0),U,3) I V Q 1_"^"_$P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P(^RAMIS(71,$P(^AUPNVRAD(G,0),U),0),U)_"^"_G
  1.  Q ""
  1. CPTI(P,BDATE,EDATE,CPTI,SCEX,SCLN,SMOD) ;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.  S SCEX=$G(SCEX)
  1.  S SCLN=$G(SCLN)
  1.  S SMOD=$G(SMOD)
  1.  I '$D(^ICPT(CPTI)) Q ""  ;not a valid cpt ien
  1.  I '$D(^AUPNVCPT("AA",P)) Q ""  ;no cpts for this patient
  1.  NEW D,BD,ED,X,Y,D,G,V,I,M,M1,Z,J,K,Q
  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)  D
  1.  .S I=0 F  S I=$O(^AUPNVCPT("AA",P,CPTI,ED,I)) Q:I'=+I!(G)  D
  1.  ..S V=$P($G(^AUPNVCPT(I,0)),U,3)
  1.  ..I SCEX]"",SCEX[$P(^AUPNVSIT(V,0),U,7) Q
  1.  ..I SCLN]"",$$CLINIC^APCLV(V,"C")=SCLN Q
  1.  ..S M=$$VAL^XBDIQ1(9000010.18,I,.08)
  1.  ..S M1=$$VAL^XBDIQ1(9000010.18,I,.09)
  1.  ..S Q=0
  1.  ..I SMOD]"" F J=1:1 S K=$P(SMOD,";",J) Q:K=""  I K=M S Q=1
  1.  ..Q:Q
  1.  ..I SMOD]"" F J=1:1 S K=$P(SMOD,";",J) Q:K=""  I K=M1 S Q=1
  1.  ..Q:Q
  1.  ..S G="1"_"^"_(9999999-ED)_"^"_$$VALI^XBDIQ1(9000010.18,I,.03)
  1.  Q G
  1.  ;
  1. TRANI(P,BDATE,EDATE,CPTI) ;EP
  1.  I '$G(P) Q ""
  1.  I $G(TRANI)="" Q ""
  1.  I $G(BDATE)="" Q ""
  1.  I $G(EDATE)="" Q ""
  1.  I '$D(^ICPT(CPTI)) Q ""
  1.  I '$D(^AUPNVTC("AC",P)) Q ""  ;no cpts for this patient
  1.  NEW X,V,C,G
  1.  S G=""
  1.  S X=0 F  S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X  D
  1.  .S C=$P($G(^AUPNVTC(X,0)),U,7)
  1.  .Q:C'=CPTI
  1.  .S V=$P(^AUPNVTC(X,0),U,3)
  1.  .S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  .Q:V<BDATE
  1.  .Q:V>EDATE
  1.  .S G="1"_"^"_V_"^"_$$VALI^XBDIQ1(9000010.33,X,.03)
  1.  Q G
  1. TRAN(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT IN A TRAN CODE
  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(^AUPNVTC("AD",V))
  1.  ..S X=0 F  S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X!(G)  D
  1.  ...I $$ICD^BGP4UTL2($P(^AUPNVTC(X,0),U,7),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(^AUPNVTC(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  I F=4 S V=$P(^AUPNVTC(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
  1.  I F=5 S V=$P(^AUPNVTC(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVTC(G,0),U,7)),U,2)
  1.  I F=6 S V=$P(^AUPNVTC(G,0),U,3) I V Q 1_"^"_$P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVTC(G,0),U,7)),U,2)_"^"_G
  1.  Q ""
  1.  ;
  1. LASTITEM(P,BD,ED,BGPT,BGPV) ;PEP - return last item APCLV OF TYPE APCLT DURING BD TO ED IN FORM APCLF
  1.  I $G(BD)="" S BD=$$DOB^AUPNPAT(P)
  1.  I $G(ED)="" S ED=DT
  1.  I $G(BGPT)="" Q ""
  1.  I $G(BGPV)="" Q ""
  1.  NEW BGPR,%,E,Y K R S %=P_"^LAST "_BGPT_" "_BGPV_";DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BGPR(")
  1.  I '$D(BGPR(1)) Q ""
  1.  Q 1_U_$P(BGPR(1),U,1)_U_$P(BGPR(1),U,3)_U_$P(BGPR(1),U,2)
  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. PAUSE ;EP - pause
  1.  K DIR,DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  S DIR("A")="Press Enter to Continue",DIR(0)="E" D ^DIR KILL DIR
  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.  ;;