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

BUDARPL3.m

Go to the documentation of this file. 
  1. BUDARPL3 ; IHS/CMI/LAB - UDS print lists ;
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;
  1. T53 ;EP
  1.  S BUDP=0
  1.  D T53H
  1.  S BUDX2L=35,BUDX2L2=0,BUDY=$O(^BUDQTFIV("B",BUDX2L,0)),BUDY=$P(^BUDQTFIV(BUDY,0),U,2)_" "_$P(^BUDQTFIV(BUDY,0),U,3)_" "_$P(^BUDQTFIV(BUDY,0),U,4)
  1.  S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D
  1.  .S BUDAGE="" F  S BUDAGE=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE)) Q:BUDAGE=""!(BUDQUIT)  D
  1.  ..S BUDSEX="" F  S BUDSEX=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX)) Q:BUDSEX=""!(BUDQUIT)  D
  1.  ...S DFN=0 F  S DFN=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN)) Q:DFN'=+DFN!(BUDQUIT)  D T5W
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  W !
  1.  Q
  1. T5W ;
  1.  I '$$DUP(DFN),'$$DUPOE(DFN,"OTH SERV"),'$$DUPOE(DFN,"ENA SERV") Q   ;NO DUPES
  1.  W !!,$E($P(^DPT(DFN,0),U,1),1,22),?24,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?36,$E(BUDCOM,1,12)
  1.  W ?51,$P(^DPT(DFN,0),U,2),?55,$$AGE^AUPNPAT(DFN,BUDCAD),?60,$E($P($$RACE^BUDARPTC(DFN),U,3)_"-"_$P($$RACE^BUDARPTC(DFN),U,4),1,19)
  1.  D MEDSERV
  1.  Q:BUDQUIT
  1.  D DENTSERV
  1.  Q:BUDQUIT
  1.  D MENTSERV
  1.  Q:BUDQUIT
  1.  D SUBSERV
  1.  Q:BUDQUIT
  1.  D OTHSERV
  1.  Q:BUDQUIT
  1.  D ENASERV
  1.  Q:BUDQUIT
  1.  Q
  1.  ;
  1. TW ;
  1.  W !?5,$$FMTE^XLFDT($P($P(^AUPNVSIT(BUDV,0),U),".")),?18,$E($$PRIMPROV^APCLV(BUDV,"E"),1,17),?36,$$PRIMPROV^APCLV(BUDV,"T"),?42,$$PRIMPROV^APCLV(BUDV,"D")
  1.  W ?48,$$PRIMPOV^APCLV(BUDV,"C"),?56,$P(^AUPNVSIT(BUDV,0),U,7),?59,$E($$CLINIC^APCLV(BUDV,"E"),1,9),?70,$E($$LOCENC^APCLV(BUDV,"E"),1,9)
  1.  Q
  1. MEDSERV ;
  1.  Q:'$$DUP(DFN,"MED SERV")
  1.  W !!,"Line 15 Total Medical Care"
  1.  I $Y>(IOSL-4) D T53H Q:BUDQUIT
  1.  S BUDD=0 F  S BUDD=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",BUDD)) Q:BUDD'=+BUDD!(BUDQUIT)  D
  1.  .Q:$P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",BUDD),U,2)=""
  1.  .F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",BUDD),U,BUDPIEC) Q:BUDV=""!(BUDQUIT)  D
  1.  ..I $Y>(IOSL-3) D T53H Q:BUDQUIT
  1.  ..D TW
  1.  ..Q
  1.  Q
  1. DENTSERV ;
  1.  Q:'$$DUP(DFN,"DENT SERV")
  1.  W !!,"Line 19 Total Dental Services"
  1.  I $Y>(IOSL-4) D T53H Q:BUDQUIT
  1.  S BUDD=0 F  S BUDD=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",BUDD)) Q:BUDD'=+BUDD!(BUDQUIT)  D
  1.  .Q:$P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",BUDD),U,2)=""
  1.  .F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",BUDD),U,BUDPIEC) Q:BUDV=""!(BUDQUIT)  D
  1.  ..I $Y>(IOSL-3) D T53H Q:BUDQUIT
  1.  ..D TW
  1.  ..Q
  1.  Q
  1. MENTSERV ;
  1.  Q:'$$DUP(DFN,"MENT SERV")
  1.  W !!,"Line 20 Mental Health"
  1.  I $Y>(IOSL-4) D T53H Q:BUDQUIT
  1.  S BUDD=0 F  S BUDD=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",BUDD)) Q:BUDD'=+BUDD!(BUDQUIT)  D
  1.  .Q:$P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",BUDD),U,2)=""
  1.  .F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",BUDD),U,BUDPIEC) Q:BUDV=""!(BUDQUIT)  D
  1.  ..I $Y>(IOSL-3) D T53H Q:BUDQUIT
  1.  ..D TW
  1.  ..Q
  1.  Q
  1. SUBSERV ;
  1.  Q:'$$DUP(DFN,"SUB SERV")
  1.  W !!,"Line 21 Substance Abuse Services"
  1.  I $Y>(IOSL-4) D T53H Q:BUDQUIT
  1.  S BUDD=0 F  S BUDD=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",BUDD)) Q:BUDD'=+BUDD!(BUDQUIT)  D
  1.  .Q:$P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",BUDD),U,2)=""
  1.  .F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",BUDD),U,BUDPIEC) Q:BUDV=""!(BUDQUIT)  D
  1.  ..I $Y>(IOSL-3) D T53H Q:BUDQUIT
  1.  ..D TW
  1.  ..Q
  1.  Q
  1. OTHSERV ;
  1.  Q:'$$DUPOE(DFN,"OTH SERV")
  1.  W !!,"Line 22 Other Professional Services"
  1.  I $Y>(IOSL-4) D T53H Q:BUDQUIT
  1.  S BUDDIS="" F  S BUDDIS=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS)) Q:BUDDIS=""!(BUDQUIT)  D OTHSERV1
  1.  Q
  1. OTHSERV1 ;
  1.  S BUDD=0 F  S BUDD=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS,BUDD)) Q:BUDD'=+BUDD!(BUDQUIT)  D
  1.  .Q:$P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS,BUDD),U,2)=""
  1.  .F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS,BUDD),U,BUDPIEC) Q:BUDV=""!(BUDQUIT)  D
  1.  ..I $Y>(IOSL-3) D T53H Q:BUDQUIT
  1.  ..D TW
  1.  ..Q
  1.  Q
  1. ENASERV ;
  1.  Q:'$$DUPOE(DFN,"ENA SERV")
  1.  W !!,"Line 29 Total Enabling Services"
  1.  I $Y>(IOSL-4) D T53H Q:BUDQUIT
  1.  S BUDDIS="" F  S BUDDIS=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS)) Q:BUDDIS=""!(BUDQUIT)  D ENASERV1
  1.  Q
  1. ENASERV1 ;
  1.  S BUDD=0 F  S BUDD=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS,BUDD)) Q:BUDD'=+BUDD!(BUDQUIT)  D
  1.  .Q:$P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS,BUDD),U,2)=""
  1.  .F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS,BUDD),U,BUDPIEC) Q:BUDV=""!(BUDQUIT)  D
  1.  ..I $Y>(IOSL-3) D T53H Q:BUDQUIT
  1.  ..D TW
  1.  ..Q
  1.  Q
  1. DUP(DFN,T) ;
  1.  NEW X,Y,G
  1.  S G=""
  1.  S T=$G(T)
  1.  I T="" D  Q G
  1.  .F X="MED SERV","DENT SERV","MENT SERV","SUB SERV" D
  1.  ..S Y=0 S Y=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,X,Y)) I Y D
  1.  ...I $P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,X,Y),U,2)]"" S G=1
  1.  ...Q
  1.  S Y=0 F  S Y=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,T,Y)) Q:Y'=+Y  D
  1.  .I $P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,T,Y),U,2)]"" S G=1
  1.  .Q
  1.  Q G
  1.  ;
  1. DUPOE(DFN,T) ;
  1.  NEW X,Y,G
  1.  S G=""
  1.  S T=$G(T)
  1.  I T="" Q ""
  1.  S Y="" F  S Y=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,T,Y)) Q:Y'=+Y  D
  1.  .S X=0 F  S X=$O(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,T,Y,X)) Q:X'=+X  D
  1.  ..I $P(^XTMP("BUDARPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,T,Y,X),U,2)]"" S G=1
  1.  .Q
  1.  Q G
  1. T53H ;
  1.  G:'BUDGPG T5H2
  1.  K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BUDQUIT=1 Q
  1. T5H2 ;
  1.  W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
  1.  W !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
  1.  W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
  1.  W !,$$CTR("***  BPHC Uniform Data System (UDS)  ***",80)
  1.  W !,$$CTR("Patient List for Table 5 Columns B & C, Patients w/Multiple Visits on Same",80)
  1.  W !,$$CTR("Day in Same Service Categories",80)
  1.  W !,$$CTR($P(^DIC(4,BUDSITE,0),U),80)
  1.  S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) W !,$$CTR(X,80)
  1.  W !,$TR($J("",80)," ","-")
  1.  I BUDP=0 W !,"List of all patients with multiple visits on the same day for the same",!,"BPHC service category.",!,"Age is calculated as of June 30.",! D
  1.  .W !,"  R- denotes the value was obtained from the Race field"
  1.  .W !,"  C- denotes the value was obtained from the Classification/Beneficiary field"
  1.  .W !
  1.  W !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE*"
  1.  W !?5,"VISIT DATE",?18,"PROV TYPE",?36,"INI",?40,"PROV CD",?48,"PRI DX",?55,"SRV",?59,"CLINIC",?70,"LOCATION"
  1.  W !,$TR($J("",80)," ","-")
  1.  ; !!,BUDSUBT,!
  1.  S BUDP=1
  1.  Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------
  1. T3A ;EP
  1.  I $G(BUDSTMP) D STEMP^BUDARPTS
  1.  S BUDPG=0
  1.  D HEADER^BUDARPTP Q:BUDQUIT  D T3ASH
  1.  ;print out each line
  1.  S BUDZ=0 F  S BUDZ=$O(^BUDQTTA("AC",BUDZ)) Q:BUDZ>38!(BUDQUIT)  D
  1.  .S BUDC=$O(^BUDQTTA("AC",BUDZ,0))
  1.  .I $Y>(IOSL-3) D HEADER^BUDARPTP Q:BUDQUIT  D T3ASH
  1.  .S BUDY=^BUDQTTA(BUDC,0)
  1.  .S BUDX=$P(BUDY,U,2)  ;column one End control
  1.  .W !
  1.  .I BUDX<10 W " "
  1.  .W $P(BUDY,U,2),?5,$P(BUDY,U,3)
  1.  .;I +BUDX=0 Q
  1.  .W ?35,$$C($P(BUDTOT("M"),U,BUDX)),?50,$$C($P(BUDTOT("F"),U,BUDX)),?68,$$C($P(BUDTOT("ALL"),U,BUDX))
  1.  .I BUDX=20 D
  1.  ..I $Y>(IOSL-4) D HEADER^BUDARPTP Q:BUDQUIT  D T3ASH
  1.  ..W !!?10,"SUBTOTAL 0-19",?35,$$C(BUD019("M")),?50,$$C(BUD019("F")),?68,$$C(BUD019("ALL")),!
  1.  S BUDC=$O(^BUDQTTA("B",43,0))
  1.  I $Y>(IOSL-3) D HEADER^BUDARPTP Q:BUDQUIT  D T3ASH
  1.  W !,$P(^BUDQTTA(BUDC,0),U,2),?5,$P(^BUDQTTA(BUDC,0),U,3)
  1.  S BUDC=$O(^BUDQTTA("AC",39,0))
  1.  I $Y>(IOSL-2) D HEADER^BUDARPTP Q:BUDQUIT  D T3ASH
  1.  S BUDY=^BUDQTTA(BUDC,0)
  1.  S BUDX=$P(BUDY,U,2)  ;column one End control
  1.  W !
  1.  W $P(BUDY,U,2),?5,$P(BUDY,U,3)
  1.  W ?35,$$C($P(BUDTOT("M"),U,BUDX)),?50,$$C($P(BUDTOT("F"),U,BUDX)),?68,$$C($P(BUDTOT("ALL"),U,BUDX))
  1.  W !
  1.  Q
  1. T3ASH ;
  1.  W !,$$CTR($G(^BUDQTTA(1,11)),80),!
  1.  F Y=2:1:4 S X=$O(^BUDQTTA("B",Y,0)) W !,$P(^BUDQTTA(X,0),U,2),?5,$P(^BUDQTTA(X,0),U,3),?33,$P(^BUDQTTA(X,0),U,4),?50,$P(^BUDQTTA(X,0),U,5),?68,$P(^BUDQTTA(X,0),U,6)
  1.  W !,$TR($J("",80)," ","-")
  1.  Q
  1. C(X,Y) ;
  1.  I $G(Y)=1,+X=0 Q ""
  1.  I $G(Y)=2 Q "********"
  1.  S X2=0,X3=8
  1.  D COMMA^%DTC
  1.  Q X