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

BUDHRPC1.m

Go to the documentation of this file. 
  1. BUDHRPC1 ; IHS/CMI/LAB - UDS TABLE 6 ;
  1.  ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
  1.  ;
  1.  ;
  1. PT ;
  1.  I $G(BUDT6L) S ^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCCOM,BUDAGE,BUDSEX,DFN,BUDV)=$G(^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCCOM,BUDAGE,BUDSEX,DFN,BUDV))_$E(BUDVAL,1,20)_U
  1. PT1 S $P(BUDT6("V"),U,BUDORD)=$P(BUDT6("V"),U,BUDORD)+1
  1.  I $D(^TMP($J,"PATIENTS",DFN,BUDORD)) Q
  1.  S ^TMP($J,"PATIENTS",DFN,BUDORD)=""
  1.  S $P(BUDT6("P"),U,BUDORD)=$P(BUDT6("P"),U,BUDORD)+1
  1.  Q
  1. T6 ;EP
  1.  S BUDV=0 F  S BUDV=$O(^TMP($J,"VISITSTABLE6A",BUDV)) Q:BUDV'=+BUDV  D
  1.  .S BUDIEN=0 F  S BUDIEN=$O(^AUPNVPOV("AD",BUDV,BUDIEN)) Q:BUDIEN'=+BUDIEN  D
  1.  ..S BUDPOV=$$VAL^XBDIQ1(9000010.07,BUDIEN,.01),BUDPOVP=$P(^AUPNVPOV(BUDIEN,0),U,1)
  1.  ..D DX
  1. SERV1 ;NOW DO SERVICES ON FULL LIST
  1.  S BUDV=0 F  S BUDV=$O(^TMP($J,"VISITSTABLE6A",BUDV)) Q:BUDV'=+BUDV  D SERV
  1.  Q
  1. DX ;
  1.  S BUD1="",BUDGOT="" F  S BUD1=$O(^BUDHTSC("AD",BUD1)) Q:BUD1=""!(BUDGOT)  D
  1.  .S X=$O(^BUDHTSC("AD",BUD1,0))
  1.  .Q:$G(^BUDHTSC(X,1))]""
  1.  .I $$ICD^ATXCHK(BUDPOVP,$O(^ATXAX("B",BUD1,0)),9) S BUDLINE=$O(^BUDHTSC("AD",BUD1,0)),BUDORD=$P(^BUDHTSC(BUDLINE,0),U,1),BUDGOT=1
  1.  .Q:'BUDGOT
  1.  .Q:BUDLINE=""
  1.  .;
  1.  .S P=$$VALI^XBDIQ1(9000010,BUDV,.05)
  1.  .Q:P=""
  1.  .Q:$D(^TMP($J,"VISITS6DX",$$VD^APCLV(BUDV),P,BUDORD))  ;already have this dx line for this date
  1.  .S ^TMP($J,"VISITS6DX",$$VD^APCLV(BUDV),P,BUDORD)=""
  1.  .S BUDVAL=BUDPOV
  1.  .D PT
  1.  Q
  1. SERV ;
  1.  S BUDORD=30 F  S BUDORD=$O(^BUDHTSC("B",BUDORD)) Q:BUDORD'=+BUDORD  S BUDY=0 F  S BUDY=$O(^BUDHTSC("B",BUDORD,BUDY)) Q:BUDY'=+BUDY  D
  1.  .S BUDVAL=""
  1.  .Q:$P(^BUDHTSC(BUDY,0),U,2)  ;header only
  1.  .X ^BUDHTSC(BUDY,1)
  1.  .Q:BUDVAL=""
  1.  .;ALREADY HAVE THIS SERVICE FOR THIS PT ON THIS DAY?
  1.  .S P=$$VALI^XBDIQ1(9000010,BUDV,.05)
  1.  .Q:P=""
  1.  .Q:$D(^TMP($J,"VISITS6DX",$$VD^APCLV(BUDV),P,BUDORD))  ;already have this dx line for this date
  1.  .S ^TMP($J,"VISITS6DX",$$VD^APCLV(BUDV),P,BUDORD)=""
  1.  .D PT
  1.  Q
  1. MAM ;EP
  1.  S BUDVAL=$$MAMM(BUDV) I BUDVAL]"" Q
  1.  I BUDVAL="" D
  1.  .S BUDW=0 F  S BUDW=$O(^TMP($J,"MAMMS",BUDW)) Q:BUDW'=+BUDW  D
  1.  ..S D=$S($$VERSION^XPDUTL("BW")<3:$P($G(^BWPCD(BUDW,0)),U,12),1:$P(^TMP($J,"MAMMS",BUDW),U,3))
  1.  ..Q:D'=$P($P($G(^AUPNVSIT(BUDV,0)),U),".")  ;pap not on this visit date
  1.  ..Q:$D(^TMP($J,"MAMDATE",$P($P(^AUPNVSIT(BUDV,0),U),".")))  ;ALREADY HAVE A PAP ON THIS DATE
  1.  ..D PT1 S ^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","MAM",BUDW)=^TMP($J,"MAMMS",BUDW)
  1.  ..S ^TMP($J,"MAMDATE",$P($P($G(^AUPNVSIT(BUDV,0)),U),"."))=""
  1.  Q
  1. PAP1 ;
  1.  S BUDVAL=$$PAP(BUDV) I BUDVAL]"" Q
  1.  I BUDVAL="" D
  1.  .S BUDW=0 F  S BUDW=$O(^TMP($J,"PAPS",BUDW)) Q:BUDW'=+BUDW  D
  1.  ..S D=$S($$VERSION^XPDUTL("BW")<3:$P($G(^BWPCD(BUDW,0)),U,12),1:$P(^TMP($J,"PAPS",BUDW),U,3))
  1.  ..Q:D'=$P($P($G(^AUPNVSIT(BUDV,0)),U),".")
  1.  ..Q:$D(^TMP($J,"PAPDATE",$P($P(^AUPNVSIT(BUDV,0),U),".")))  ;ALREADY HAVE A PAP ON THIS DATE
  1.  ..D PT1 S ^XTMP("BUDHRPT1",BUDJ,BUDH,"T6",BUDORD,BUDCCOM,BUDAGE,BUDSEX,DFN,"WH","PAP",BUDW)=^TMP($J,"PAPS",BUDW)
  1.  ..S ^TMP($J,"PAPDATE",$P($P($G(^AUPNVSIT(BUDV,0)),U),"."))=""
  1.  Q
  1. CONTRA(BUDV) ;
  1.  S G="",X=0 F  S X=$O(^AUPNVPOV("AD",BUDV,X)) Q:X'=+X!(G]"")  S (R,I)=$P(^AUPNVPOV(X,0),U),R=$P($$ICDDX^ICDEX(R,$$VD^APCLV(BUDV)),U,2) I $$ICD^ATXCHK(I,$O(^ATXAX("B","BUD 18 T6A LINE 25",0)),9) S G=R
  1.  Q G
  1. SEASFLU(BUDV) ;
  1.  S G="" S X=0 F  S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"")  D
  1.  .S Z=$P(^AUPNVCPT(X,0),U)
  1.  .S Z=$P($$CPT^ICPTCOD(Z),U,2)
  1.  .I $D(^BUDHTSC(BUDY,8,"B",Z)) S G=Z
  1.  .Q
  1.  I G]"" Q "V CPT: "_G
  1.  S G="",X=0 F  S X=$O(^AUPNVIMM("AD",BUDV,X)) Q:X'=+X!(G]"")  D
  1.  .S Z=$P(^AUPNVIMM(X,0),U),Z=+$P(^AUTTIMM(Z,0),U,3)
  1.  .I $D(^BUDHTSC(BUDY,9,"B",Z)) S G=Z_" imm"
  1.  .Q
  1.  Q G
  1.  ;
  1.  ;
  1. PAP(BUDV) ;
  1.  S T=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
  1.  S G="" I T S X=0 F  S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"")  S R=$P($G(^AUPNVLAB(X,0)),U) I R,$D(^ATXLAB(T,21,"B",R)) S G=$P(^LAB(60,R,0),U)
  1.  I G]"" Q "V LAB: "_G
  1.  S X=0 F  S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"")  S R=$P(^AUPNVLAB(X,0),U),R=$P(^LAB(60,R,0),U) I R="PAP SMEAR" S G=R
  1.  I G]"" Q "V LAB: "_G
  1.  S G="" S X=0 F  S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"")  D
  1.  .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
  1.  .I $D(^BUDHTSC(BUDY,8,"B",Z)) S G=Z
  1.  .Q
  1.  I G]"" Q "V CPT: "_G
  1.  S X=0,G="" F  S X=$O(^AUPNVPOV("AD",BUDV,X)) Q:X'=+X!(G]"")  D
  1.  .S Z=+^AUPNVPOV(X,0) I $$ICD^ATXCHK(Z,$O(^ATXAX("B","BUD 18 T6A LINE 23",0)),9) S G=$P($$ICDDX^ICDEX(Z),U,2)
  1.  I G]"" Q "V POV: "_G
  1.  S T=$O(^ATXAX("B","BGP PAP LOINC CODES",0))
  1.  S G="" I T S X=0 F  S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"")  D
  1.  .S J=$P($G(^AUPNVLAB(X,11)),U,13)
  1.  .Q:J=""
  1.  .Q:'$$LOINC(J,T)
  1.  .S G=J
  1.  I G]"" Q "V LAB LOINC: "_G
  1.  Q ""
  1. IMM(BUDV) ;
  1.  S G="" S X=0 F  S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"")  D
  1.  .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
  1.  .I $D(^BUDHTSC(BUDY,8,"B",Z)) S G=Z
  1.  .Q
  1.  I G]"" Q "V CPT: "_G
  1.  S G="",X=0 F  S X=$O(^AUPNVIMM("AD",BUDV,X)) Q:X'=+X!(G]"")  D
  1.  .S Z=$P(^AUPNVIMM(X,0),U),Z=+$P(^AUTTIMM(Z,0),U,3)
  1.  .I $D(^BUDHTSC(BUDY,9,"B",Z)) S G=Z_" imm"
  1.  .Q
  1.  Q G
  1. HIV(BUDV) ;EP
  1.  S T=$O(^ATXLAB("B","BGP HIV TEST TAX",0))
  1.  S G="" I T S X=0 F  S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"")  S R=$P($G(^AUPNVLAB(X,0)),U) I R,$D(^ATXLAB(T,21,"B",R)) S G=$P(^LAB(60,R,0),U)
  1.  I G]"" Q "V LAB: "_G
  1.  ;S T=$O(^ATXAX("B","BUD CPT HIV TESTS",0))
  1.  S G="" S X=0 F  S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"")  D
  1.  .S Z=$P(^AUPNVCPT(X,0),U)
  1.  .S %=$$VAL^XBDIQ1(9000010.18,X,.01)
  1.  .I $D(^BUDHTSC(BUDY,8,"B",%)) S G=$P($$CPT^ICPTCOD(Z),U,2)
  1.  .Q
  1.  I G]"" Q "V CPT: "_G
  1.  S T=$O(^ATXAX("B","BGP HIV TEST LOINC CODES",0))
  1.  S G="" I T S X=0 F  S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"")  D
  1.  .S J=$P($G(^AUPNVLAB(X,11)),U,13)
  1.  .Q:J=""
  1.  .Q:'$$LOINC(J,T)
  1.  .S G=J
  1.  I G]"" Q "V LAB LOINC: "_G
  1.  Q ""
  1. LOINC(A,B) ;
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1.  I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I $D(^ATXAX(B,21,"B",%)) Q 1
  1.  Q ""
  1. MAMM(BUDV) ;
  1.  S X=0,G="" F  S X=$O(^AUPNVRAD("AD",BUDV,X)) Q:X'=+X  D
  1.  .S Z=$P(^AUPNVRAD(X,0),U),Z=$P(^RAMIS(71,Z,0),U,9) I Z S Y=$P($$CPT^ICPTCOD(Z),U,2)
  1.  .I Y,$D(^BUDHTSC(BUDY,8,"B",Y)) S G=Y
  1.  I G]"" Q "V RAD: "_G
  1.  S X=0,G="" F  S X=$O(^AUPNVPOV("AD",BUDV,X)) Q:X'=+X  D
  1.  .S Z=$P(^AUPNVPOV(X,0),U)
  1.  .I $$ICD^ATXCHK(Z,$O(^ATXAX("B","BUD 18 T6A LINE 22",0)),9) S G=$P(^ICD9(Z,0),U,1)
  1.  I G]"" Q "V POV: "_G
  1.  S X=0,G="" F  S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X  D
  1.  .S Z=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Z),U,2)
  1.  .I Y,$D(^BUDHTSC(BUDY,8,"B",Y)) S G="V CPT: "_Y
  1.  I G]"" Q "V CPT: "_Y
  1.  Q ""
  1. HEPB(BUDV) ;
  1.  S T=$O(^ATXLAB("B","BUD HEPATITIS B TESTS",0))
  1.  S G="" I T S X=0 F  S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"")  S R=$P($G(^AUPNVLAB(X,0)),U) I R,$D(^ATXLAB(T,21,"B",R)) S G=$P(^LAB(60,R,0),U)
  1.  I G]"" Q "V LAB: "_G
  1.  S G="" S X=0 F  S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"")  D
  1.  .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
  1.  .I $D(^BUDHTSC(BUDY,8,"B",Z)) S G=$P($$CPT^ICPTCOD(Z),U,2)
  1.  .Q
  1.  I G]"" Q "V CPT: "_G
  1.  Q ""
  1. HEPC(BUDV) ;
  1.  S T=$O(^ATXLAB("B","BUD HEPATITIS C TESTS",0))
  1.  S G="" I T S X=0 F  S X=$O(^AUPNVLAB("AD",BUDV,X)) Q:X'=+X!(G]"")  S R=$P($G(^AUPNVLAB(X,0)),U) I R,$D(^ATXLAB(T,21,"B",R)) S G=$P(^LAB(60,R,0),U)
  1.  I G]"" Q "V LAB: "_G
  1.  S G="" S X=0 F  S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"")  D
  1.  .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
  1.  .I $D(^BUDHTSC(BUDY,8,"B",Z)) S G=$P($$CPT^ICPTCOD(Z),U,2)
  1.  .Q
  1.  I G]"" Q "V CPT: "_G
  1.  Q ""