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

BUDRPTC1.m

Go to the documentation of this file. 
  1. BUDRPTC1 ; IHS/CMI/LAB - UDS TABLE 6 ;
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;
  1.  ;
  1. PT ;
  1.  I $G(BUDT6L) S ^XTMP("BUDRPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$E(BUDVAL,1,20)
  1.  S $P(BUDT6("V"),U,C)=$P(BUDT6("V"),U,C)+1
  1.  I $D(^TMP($J,"PATIENTS",DFN,C)) Q
  1.  S ^TMP($J,"PATIENTS",DFN,C)=""
  1.  S $P(BUDT6("P"),U,C)=$P(BUDT6("P"),U,C)+1
  1.  Q
  1. OT ;
  1.  I $D(^XTMP("BUDRPT1",BUDJ,BUDH,"T6",C,BUDCOM,BUDAGE,BUDSEX,DFN)) Q  ;patient already a hit on this line
  1.  S ^XTMP("BUDRPT1",BUDJ,BUDH,"ORPHANS",C,BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$E(BUDVAL,1,20)
  1.  Q
  1. T6 ;EP
  1.  S BUDV=0 F  S BUDV=$O(^TMP($J,"VISITSLIST",BUDV)) Q:BUDV'=+BUDV  D
  1.  .D SERV
  1.  .S BUDP=$$PRIMPROV^APCLV(BUDV,"D") Q:BUDP=""
  1.  .S BUDPOV=$$PRIMPOV^APCLV(BUDV,"C") Q:BUDPOV=""  S BUDPOVP=$$PRIMPOV^APCLV(BUDV,"I")
  1.  .Q:$E(BUDPOV)="."
  1.  .Q:$E(BUDPOV)="E"
  1.  .D PRIMDX
  1.  ; now go through orphans if report is wanted
  1.  Q:'$G(BUDTOL)
  1.  S BUDV=0 F  S BUDV=$O(^TMP($J,"ORPHANS",BUDV)) Q:BUDV'=+BUDV  D
  1.  .S BUDVAL=$$HIV(BUDV) I BUDVAL]"" S C=21 D PT
  1.  .S BUDVAL=$$MAMM(BUDV) I BUDVAL]"" S C=22 D PT
  1.  .S BUDVAL=$$PAP(BUDV) I BUDVAL]"" S C=23 D PT
  1.  .S BUDVAL=$$IMM(BUDV) I BUDVAL]"" S C=24 D PT
  1.  .S BUDVAL=$$CONTRA(BUDV) I BUDVAL]"" S C=25 D PT
  1.  .S Y=0 S BUDVAL=$$L26(BUDV) I BUDVAL]"" S C=26 D PT
  1.  .Q
  1.  Q
  1. PRIMDX ;
  1.  I $E(BUDPOV,1,3)="042" S C=1 S BUDVAL=BUDPOV D PT Q
  1.  I $E(BUDPOV,1,3)="V08" S C=2 S BUDVAL=BUDPOV D PT Q
  1.  S X=$E(BUDPOV,1,3) I X="010"!(X="011")!(X="012")!(X="013")!(X="014")!(X="015")!(X="016")!(X="017")!(X="018") S C=3 S BUDVAL=BUDPOV D PT Q
  1.  S X=$E(BUDPOV,1,3) I X="090"!(X="091")!(X="092")!(X="093")!(X="094")!(X="095")!(X="096")!(X="097")!(X="098")!(X="099") S C=4 S BUDVAL=BUDPOV D PT Q
  1.  I $E(BUDPOV,1,3)=493 S C=5 S BUDVAL=BUDPOV D PT Q
  1.  S X=$E(BUDPOV,1,3) I X=490!(X=491)!(X=492)!(X=496) S C=6 S BUDVAL=BUDPOV D PT Q
  1.  S X=$E(BUDPOV,1,3) I X=174!(BUDPOV=198.81)!($E(BUDPOV,1,5)="233.0")!(BUDPOV=793.8) S C=7 S BUDVAL=BUDPOV D PT Q
  1.  I $E(BUDPOV,1,3)=180!(BUDPOV=198.82)!($E(BUDPOV,1,5)="233.1")!($E(BUDPOV,1,5)="795.0") S C=8 S BUDVAL=BUDPOV D PT Q
  1.  I $E(BUDPOV,1,3)=250!($E(BUDPOV,1,5)="775.1")!(BUDPOV="790.2") S C=9 S BUDVAL=BUDPOV D PT Q
  1.  I $E(BUDPOV,1,3)=391!($E(BUDPOV,1,5)="392.0")!($E(BUDPOV,1,3)>409)&($E(BUDPOV,1,3)<430) S C=10 S BUDVAL=BUDPOV D PT Q
  1.  I $E(BUDPOV,1,3)>400&($E(BUDPOV,1,3)<406) S C=11 S BUDVAL=BUDPOV D PT Q
  1.  I $E(BUDPOV,1,3)=692 S C=12 S BUDVAL=BUDPOV D PT Q
  1.  I $E(BUDPOV,1,5)="276.5" S C=13 S BUDVAL=BUDPOV D PT Q
  1.  I $E(BUDPOV,1,3)=991!($E(BUDPOV,1,3)=992) S C=14 S BUDVAL=BUDPOV D PT Q
  1.  I $E(BUDPOV,1,3)=381!($E(BUDPOV,1,3)=382) S C=15 S BUDVAL=BUDPOV D PT Q
  1.  S T=$O(^ATXAX("B","BUD TABLE 6 LINE 16",0))
  1.  I $$ICD^ATXCHK(BUDPOVP,T,9) S C=16 S BUDVAL=BUDPOV D PT Q
  1.  S T=$O(^ATXAX("B","BUD TABLE 6 LINE 17",0))
  1.  I $$ICD^ATXCHK(BUDPOVP,T,9) S C=17 S BUDVAL=BUDPOV D PT Q
  1.  I $E(BUDPOV,1,3)=303!($E(BUDPOV,1,3)=291)!($E(BUDPOV,1,5)="357.5")!($E(BUDPOV,1,5)="305.0") S C=18 S BUDVAL=BUDPOV D PT Q
  1.  S T=$O(^ATXAX("B","BUD TABLE 6 LINE 19",0))
  1.  I $$ICD^ATXCHK(BUDPOVP,T,9) S C=19 S BUDVAL=BUDPOV D PT Q
  1.  S T=$O(^ATXAX("B","BUD TABLE 6 LINE 20",0))
  1.  I $$ICD^ATXCHK(BUDPOVP,T,9) S C=20 S BUDVAL=BUDPOV D PT Q
  1.  Q
  1. SERV ;
  1.  S BUDVAL=$$HIV(BUDV) I BUDVAL]"" S C=21 D PT
  1.  S BUDVAL=$$MAMM(BUDV) I BUDVAL]"" S C=22 D PT
  1.  S BUDVAL=$$PAP(BUDV) I BUDVAL]"" S C=23 D PT
  1.  S BUDVAL=$$IMM(BUDV) I BUDVAL]"" S C=24 D PT
  1.  S BUDVAL=$$CONTRA(BUDV) I BUDVAL]"" S C=25 D PT
  1.  S Y=0 S BUDVAL=$$L26(BUDV) I BUDVAL]"" S C=26 D PT
  1.  Q
  1. CONTRA(BUDV) ;
  1.  S G="",X=0 F  S X=$O(^AUPNVPOV("AD",BUDV,X)) Q:X'=+X!(G]"")  S R=$P(^AUPNVPOV(X,0),U),R=$P($$ICDDX^ICDCODE(Z),U,2) I $E(R,1,3)="V25" S G=R
  1.  Q G
  1. L26(BUDV) ;
  1.  I $$AGE^AUPNPAT($P(^AUPNVSIT(BUDV,0),U,5),BUDCAD)>11 Q ""
  1.  I $$CLINIC^APCLV(BUDV,"C")=24 Q "CLIN 24"
  1.  I $$CLINIC^APCLV(BUDV,"C")=57 Q "CLIN 57"
  1.  S X=0,G="" F  S X=$O(^AUPNVPOV("AD",BUDV,X)) Q:X'=+X!(G]"")  S R=$P(^AUPNVPOV(X,0),U),R=$P($$ICDDX^ICDCODE(Z),U,2) I $E(R,1,3)="V20"!($E(R,1,3)="V29") S G=R
  1.  I G]"" Q G
  1.  S T=$O(^ATXAX("B","BUD L26 CPTS",0))
  1.  S G="" I T 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.  .I $$ICD^ATXCHK(Z,T,1) S G=$P($$CPT^ICPTCOD(Z),U,2)
  1.  .Q
  1.  Q G
  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 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 G
  1.  S T=$O(^ATXAX("B","BUD CPT PAP 03",0))
  1.  S G="" I T 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.  .I $$ICD^ATXCHK(Z,T,1) S G=$P($$CPT^ICPTCOD(Z),U,2)
  1.  .Q
  1.  I G]"" Q G
  1.  S X=0,G="" F  S X=$O(^AUPNVPOV("AD",BUDV,X)) Q:X'=+X!(G]"")  D
  1.  .S Z=$P(^AUPNVPOV(X,0),U),Z=$P($$ICDDX^ICDCODE(Z),U,2)
  1.  .I Z="V76.2"!(Z="V72.3") S G=Z
  1.  I G]"" Q G
  1.  S X=0,G="" F  S X=$O(^AUPNVPRC("AD",BUDV,X)) Q:X'=+X!(G]"")  D
  1.  .S Z=$P(^AUPNVPRC(X,0),U),Z=$P($$ICDOP^ICDCODE(Z),U,2)
  1.  .I Z="91.46" S G=Z
  1.  I G]"" Q 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.  .S J=$P($G(^LAB(95.3,J,9999999)),U,2)
  1.  .I $D(^ATXAX(T,21,"B",J)) S G=J
  1.  I G]"" Q G
  1.  Q ""
  1. IMM(BUDV) ;
  1.  S T=$O(^ATXAX("B","BUD IMM CPTS",0))
  1.  S G="" I T 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.  .I $$ICD^ATXCHK(Z,T,1) S G=$P($$CPT^ICPTCOD(Z),U,2)
  1.  .Q
  1.  I G]"" Q 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(^BUDCNTL(2,11,"B",Z)) S G=Z_" imm"
  1.  .Q
  1.  Q G
  1. HIV(BUDV) ;
  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 G
  1.  S T=$O(^ATXAX("B","BUD CPT HIV TESTS",0))
  1.  S G="" I T 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.  .I $$ICD^ATXCHK(Z,T,1) S G=$P($$CPT^ICPTCOD(Z),U,2)
  1.  .Q
  1.  I G]"" Q 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.  .S J=$P($G(^LAB(95.3,J,9999999)),U,2)
  1.  .I $D(^ATXAX(T,21,"B",J)) S G=J
  1.  I G]"" Q G
  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 Z=$P($$CPT^ICPTCOD(Z),U,2)
  1.  .I Z=76091!(Z=76090)!(Z=76092) S G=Z
  1.  I G]"" Q 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),Z=$P($$ICDDX^ICDCODE(Z),U,2)
  1.  .I Z="V76.11"!(Z="V76.12") S G=Z
  1.  I G]"" Q G
  1.  S X=0,G="" F  S X=$O(^AUPNVPRC("AD",BUDV,X)) Q:X'=+X  D
  1.  .S Z=$P(^AUPNVPRC(X,0),U),Z=$P($$ICDOP^ICDCODE(Z),U,2)
  1.  .I Z="87.37"!(Z="87.36")!(Z="87.35") S G=Z
  1.  I G]"" Q 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),Z=$P($$CPT^ICPTCOD(Z),U,2)
  1.  .I Z=76091!(Z=76090)!(Z=76092) S G=Z
  1.  .Q
  1.  Q G