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

BGP0CPU4.m

Go to the documentation of this file. 
  1. BGP0CPU4 ; IHS/CMI/LAB - calc CMS measures ;
  1.  ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
  1.  ;
  1.  ;
  1. WPOSTINF ;EP
  1.  I $Y>(BGPIOSL-8) D HDR^BGP0CP Q:BGPQUIT  D L1H^BGP0CP
  1.  W !!?2,"Post-Operative Infection?  ",BGPPOSTI
  1.  I BGPPOSTI="" Q
  1.  W !?2,"NOTE:  Review patient's chart to determine if patient should be excluded"
  1.  W !,"to see if all conditions are true: 1) there is physician/APN/PA documentation"
  1.  W !,"the patient is being treated for an infection, 2) infection occurred during"
  1.  W !,"specified timeframe, and 3) where treatment was administered via an "
  1.  W !,"antibiotic administration route listed in the SIP inclusions for the"
  1.  W !,"Data Element 'Antibiotic Administration Route.'"
  1.  Q
  1.  ;
  1. PERI ;EP
  1.  I $Y>(BGPIOSL-3) D HDR^BGP0CP Q:BGPQUIT  D L1H^BGP0CP
  1.  W !!?2,$S(BGPPEX[1:"*",1:""),"Preoperative Infectious Disease Diagnosis?  ",$P($$ADMPRIM^BGP0CU5(BGPVINP,"BGP CMS INFECTIOUS DXS"),U,2)
  1.  Q
  1.  ;
  1. WANTIRX ;EP
  1.  S X=0,C=0 F  S X=$O(BGPDATA(X)) Q:X'=+X  S C=C+1
  1.  I $Y>(BGPIOSL-(C+3)) D HDR^BGP0CP Q:BGPQUIT  D L1H^BGP0CP
  1.  W !!?2,"Recent Antibiotic Rx Status:  "
  1.  I $D(BGPDATA) S X=0 F  S X=$O(BGPDATA(X)) Q:X'=+X  W !?4,BGPDATA(X)
  1.  ;W !
  1.  Q
  1.  ;
  1. OTHSURG ;EP
  1.  I $Y>(BGPIOSL-3) D HDR^BGP0CP Q:BGPQUIT  D L1H^BGP0CP
  1.  W !!?2,"Other Surgery with Anesthesia?  "
  1.  K BGPG
  1.  K BGPY S BGPC=0,F=""
  1.  K BGPG
  1.  S Y="BGPG("
  1.  S X=DFN_"^ALL PROCEDURES;DURING "_$$VD^APCLV(BGPVSIT)_"-"_$$DSCH^BGP0CU(BGPVINP) S E=$$START1^APCLDF(X,Y)
  1.  S Y=0 F  S Y=$O(BGPG(Y)) Q:Y'=+Y  S X=+$P(BGPG(Y),U,4) D
  1.  .Q:'$D(^AUPNVPRC(X,0))
  1.  .Q:$P(^AUPNVPRC(X,0),U)=$P(BGPPROC(1),U,2)
  1.  .;Q:$P(^AUPNVPRC(X,0),U,8)'="Y"
  1.  .S D=$S($P(^AUPNVPRC(X,0),U,6)]"":$P(^AUPNVPRC(X,0),U,6),1:$P($P(BGPVSIT0,U),"."))
  1.  .S E=$P(BGPPROC(1),U,3)
  1.  .I $$ABS^XLFMTH($$FMDIFF^XLFDT(D,E))>4 Q  ;more than 4 days
  1.  .W !?4,$$VAL^XBDIQ1(9000010.08,X,.01),"  ",$$DATE^BGP0UTL(D),"  ",$$VAL^XBDIQ1(9000010.08,X,.04) S F=1
  1.  Q:'F
  1.  W !,"NOTE:  To determine if patient should be excluded, review patients chart"
  1.  W !,"to determine if anesthesia was general or spinal anesthesia and occurred"
  1.  W !,"during the specified timeframe."
  1.  Q
  1.  ;
  1. INF ;EP
  1.  I $Y>(BGPIOSL-5) D HDR^BGP0CP Q:BGPQUIT  D L1H^BGP0CP
  1.  W !!?2,"Infection Documented at Time of Surgery?  ",$S($P(BGPPROC(1),U,4)="":"NO",1:$P(BGPPROC(1),U,4))
  1.  I BGPPROC(1)="" Q
  1.  I $P(BGPPROC(1),U,4)="" Q
  1.  I $P(BGPPROC(1),U,4)["N" Q
  1.  W !,"NOTE:  Review patient's chart to determine if patient should be excluded"
  1.  W !,"when infection was present to see if infection was documented by "
  1.  W !,"physician/APN/PA prior to this surgery."
  1.  Q
  1. WOTHPROC ;EP
  1.  K BGPXX
  1.  S BGPC=0
  1.  S BGPB=(9999999-$$DSCH^BGP0CU(BGPVINP))-1,BGPE=9999999-$P($P(^AUPNVSIT(BGPVSIT,0),U),".")
  1.  F  S BGPB=$O(^AUPNVPRC("AA",DFN,BGPB)) Q:BGPB'=+BGPB!(BGPB>BGPE)  D
  1.  .S X=0 F  S X=$O(^AUPNVPRC("AA",DFN,BGPB,X)) Q:X'=+X  D
  1.  ..Q:'$D(^AUPNVPRC(X,0))
  1.  ..Q:$P(^AUPNVPRC(X,0),U)=$P(BGPPROC(1),U,2)
  1.  ..S BGPC=BGPC+1,BGPXX(BGPC)=$$VAL^XBDIQ1(9000010.08,X,.01)_"  "_$$VAL^XBDIQ1(9000010.08,X,.04)
  1.  ;go through visits in a date range for this patient, check cpts
  1.  NEW D,BD,ED,Y,D,V
  1.  S BGPB=9999999-$$DSCH^BGP0CU(BGPVINP),BGPE=9999999-$P($P(^AUPNVSIT(BGPVSIT,0),U),".")
  1.  F  S BGPB=$O(^AUPNVSIT("AA",DFN,BGPB)) Q:BGPB=""!($P(BGPB,".")>BGPE)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",DFN,BGPB,V)) Q:V'=+V  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  D
  1.  ...S BGPC=BGPC+1,BGPXX(BGPC)=$$VAL^XBDIQ1(9000010.18,X,.01)_"  "_$P($$CPT^ICPTCOD($P(^AUPNVCPT(X,0),U),(9999999-BGPB)),U,3)
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  S (C,X)=0 F  S X=$O(BGPXX(X)) Q:X'=+X  S C=C+1
  1.  I $Y>(BGPIOSL-(C+3)) D HDR^BGP0CP Q:BGPQUIT  D L1H^BGP0CP
  1.  W !?2,"Other Procedures for this Visit:"
  1.  S BGPX=0 F  S BGPX=$O(BGPXX(BGPX)) Q:BGPX'=+BGPX  W !?4,BGPXX(BGPX)
  1.  Q
  1.  ;
  1. WPP1 ;EP
  1.  I $Y>(BGPIOSL-4) D HDR^BGP0CP Q:BGPQUIT  D L1H^BGP0CP
  1.  W !?2,"Principle Procedure:  ",$P(BGPPROC(1),U,1)
  1.  S X=1 F  S X=$O(BGPPROC(X)) Q:X'=+X  W !?23,$P(BGPPROC(X),U,1)
  1.  W !?2,$S(BGPPPD<$P($P(BGPVSIT0,U),"."):"*",1:""),"Principle Procedure Date:  ",$$DATE^BGP0UTL(BGPPPD)
  1.  Q
  1.  ;
  1. WPP ;EP
  1.  I $Y>(BGPIOSL-3) D HDR^BGP0CP Q:BGPQUIT  D L1H^BGP0CP
  1.  W:'$D(BGPNOBA) ! W !?2,"Principle Procedure:  ",BGPDATA(1)
  1.  S X=1 F  S X=$O(BGPDATA(X)) Q:X'=+X  W !?23,BGPDATA(X)
  1.  Q
  1.  ;
  1. WDOD(V) ;EP - write dod
  1.  I $Y>(BGPIOSL-2) D HDR^BGP0CP Q:BGPQUIT  D L1H^BGP0CP
  1.  I $$DOD^AUPNPAT(V)]"" D
  1.  .W !!?2,"*Date of Death:  ",$$DATE^BGP0UTL($$DOD^AUPNPAT(V))
  1.  Q
  1.  ;
  1. WDT(V) ;EP - write discharge type at column 3
  1.  I $Y>(BGPIOSL-2) D HDR^BGP0CP Q:BGPQUIT  D L1H^BGP0CP
  1.  W:'$D(BGPNOBA) ! W !?2,"Discharge Type:  ",$$VAL^XBDIQ1(9000010.02,V,.06)
  1.  Q
  1.  ;
  1. WTT(V) ;EP - write transferred to
  1.  I $Y>(BGPIOSL-2) D HDR^BGP0CP Q:BGPQUIT  D L1H^BGP0CP
  1.  W !?2,"Transferred to:  ",$$VAL^XBDIQ1(9000010.02,V,.09)
  1.  Q
  1.  ;
  1. WPPDPOV(V) ;EP
  1.  I $Y>(BGPIOSL-2) D HDR^BGP0CP Q:BGPQUIT  D L1H^BGP0CP
  1.  W:'$D(BGPNOBA) ! W !?2,"Primary Discharge POV: "_$$PRIMPOV^APCLV(V,"C"),"  ",$$PRIMPOV^APCLV(V,"N")
  1.  Q
  1.  ;
  1.  ;
  1. OTHDPOVS(V) ;EP write out other discharge povs
  1.  NEW X,C
  1.  S (X,C)=0 F  S X=$O(^AUPNVPOV("AD",BGPVSIT,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVPOV(X,0))
  1.  .Q:$P(^AUPNVPOV(X,0),U,12)="P"
  1.  .S C=C+1
  1.  .Q
  1.  I $Y>(BGPIOSL-(C+2)) D HDR^BGP0CP Q:BGPQUIT  D L1H^BGP0CP
  1.  W !!?2,"Other Discharge POVs for this visit:",$S(C=0:"  None",1:"")
  1.  S (X,C)=0 F  S X=$O(^AUPNVPOV("AD",BGPVSIT,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVPOV(X,0))
  1.  .Q:$P(^AUPNVPOV(X,0),U,12)="P"
  1.  .S C=C+1
  1.  .S I=$P(^AUPNVPOV(X,0),U),I=$P($$ICDDX^ICDCODE(I),U,2)
  1.  .S N=$$VAL^XBDIQ1(9000010.07,X,.04),N=$$UP^XLFSTR(N)
  1.  .W !?4,I,?11,N
  1.  Q
  1. GETTXT ;EP - GENERALIZED TEXT PRINTER
  1.  S BGPLETP("DLT")=1,BGPLETP("ILN")=75
  1.  F BGPLETP("Q")=0:0 S:BGPLETP("NRQ")]""&(($L(BGPLETP("NRQ"))+$L(BGPLETP("TXT"))+2)<255) BGPLETP("TXT")=$S(BGPLETP("TXT")]"":BGPLETP("TXT")_"; ",1:"")_BGPLETP("NRQ"),BGPLETP("NRQ")="" Q:BGPLETP("TXT")=""  D GETTXT2
  1.  K BGPLETP("ILN"),BGPLETP("DLT"),BGPLETP("F"),BGPLETP("C"),BGPLETP("TXT")
  1.  Q
  1. GETTXT2 D GETFRAG S BGPLEC=BGPLEC+1,BGPLETXT(BGPLEC)="" F X=1:1:BGPLETP("ICL") S BGPLETXT(BGPLEC)=BGPLETXT(BGPLEC)_" "
  1.  S BGPLETXT(BGPLEC)=BGPLETXT(BGPLEC)_BGPLETP("F"),BGPLETP("ICL")=BGPLETP("ICL")+BGPLETP("DLT"),BGPLETP("ILN")=BGPLETP("ILN")-BGPLETP("DLT"),BGPLETP("DLT")=0
  1.  Q
  1. GETFRAG I $L(BGPLETP("TXT"))<BGPLETP("ILN") S BGPLETP("F")=BGPLETP("TXT"),BGPLETP("TXT")="" Q
  1.  F BGPLETP("C")=BGPLETP("ILN"):-1:1 Q:$E(BGPLETP("TXT"),BGPLETP("C"))=" "
  1.  S BGPLETP("F")=$E(BGPLETP("TXT"),1,BGPLETP("C")-1),BGPLETP("TXT")=$E(BGPLETP("TXT"),BGPLETP("C")+1,255)
  1.  Q