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

BUD7RPL3.m

Go to the documentation of this file. 
  1. BUD7RPL3 ; 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 BUD7L=35,BUD7L2=0,BUDY=$O(^BUDETFIV("B",BUD7L,0)),BUDY=$P(^BUDETFIV(BUDY,0),U,2)
  1.  S BUDCOM="" F  S BUDCOM=$O(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM)) Q:BUDCOM=""!(BUDQUIT)  D
  1.  .S BUDAGE="" F  S BUDAGE=$O(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE)) Q:BUDAGE=""!(BUDQUIT)  D
  1.  ..S BUDSEX="" F  S BUDSEX=$O(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX)) Q:BUDSEX=""!(BUDQUIT)  D
  1.  ...S DFN=0 F  S DFN=$O(^XTMP("BUD7RPT1",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) 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,$P($$RACE^BUD7RPTC(DFN),U,2)
  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("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",BUDD)) Q:BUDD'=+BUDD!(BUDQUIT)  D
  1.  .Q:$P(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",BUDD),U,2)=""
  1.  .F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUD7RPT1",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("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",BUDD)) Q:BUDD'=+BUDD!(BUDQUIT)  D
  1.  .Q:$P(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",BUDD),U,2)=""
  1.  .F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUD7RPT1",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 Services"
  1.  I $Y>(IOSL-4) D T53H Q:BUDQUIT
  1.  S BUDD=0 F  S BUDD=$O(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",BUDD)) Q:BUDD'=+BUDD!(BUDQUIT)  D
  1.  .Q:$P(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",BUDD),U,2)=""
  1.  .F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUD7RPT1",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("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",BUDD)) Q:BUDD'=+BUDD!(BUDQUIT)  D
  1.  .Q:$P(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",BUDD),U,2)=""
  1.  .F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUD7RPT1",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("BUD7RPT1",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("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS,BUDD)) Q:BUDD'=+BUDD!(BUDQUIT)  D
  1.  .Q:$P(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDDIS,BUDD),U,2)=""
  1.  .F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUD7RPT1",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("BUD7RPT1",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("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS,BUDD)) Q:BUDD'=+BUDD!(BUDQUIT)  D
  1.  .Q:$P(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDDIS,BUDD),U,2)=""
  1.  .F BUDPIEC=1:1 S BUDV=$P(^XTMP("BUD7RPT1",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("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,X,Y)) I Y D
  1.  ...I $P(^XTMP("BUD7RPT1",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("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,T,Y)) Q:Y'=+Y  D
  1.  .I $P(^XTMP("BUD7RPT1",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("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,T,Y)) Q:Y'=+Y  D
  1.  .S X=0 F  S X=$O(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,T,Y,X)) Q:X'=+X  D
  1.  ..I $P(^XTMP("BUD7RPT1",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.",!
  1.  W !,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"AGE",?60,"RACE/ETHN"
  1.  W !?5,"VISIT DATE",?18,"PROV TYPE",?36,"INI",?41,"DISC",?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.  ;----------