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