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

APCLOP1.m

Go to the documentation of this file. 
  1. APCLOP1 ; IHS/CMI/LAB - list procedures and tally operation provider ;
  1.  ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
  1.  ;
  1.  ;cmi/anch/maw 9/10/2007 code set versioning in PROC1,PRINT
  1.  ;
  1. INFORM ;
  1.  W !,$$CTR($$USR)
  1.  W !,$$LOC()
  1.  W !!,$$CTR("LISTING/TALLY OF OF VISITS WITH SELECTED PROCEDURE CODES",80)
  1.  W !!,"This report will tally the operating provider for selected procedures"
  1.  W !,"done.  You can optionally get a list of all the visits with these"
  1.  W !,"procedures."
  1.  W !
  1.  D EOJ
  1.  S APCLH=$H,APCLJ=$J
  1.  K ^XTMP("APCLOP1",APCLJ,APCLH)
  1.  D XTMP^APCLOSUT("APCLOP1","PROCEDURES REPORT")
  1. DATES K APCLED,APCLBD
  1.  K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Visit Date"
  1.  D ^DIR Q:Y<1  S APCLBD=Y
  1.  K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Visit Date"
  1.  D ^DIR Q:Y<1  S APCLED=Y
  1.  ;
  1.  I APCLED<APCLBD D  G DATES
  1.  . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
  1.  ;
  1. SC ;type of refusal all or one?
  1.  K APCLSCT
  1.  K APCLSC,APCLSCT W ! S DIR(0)="YO",DIR("A")="Include ALL Visit Service Categories",DIR("B")="Yes"
  1.  S DIR("?")="If you wish to include all visit service categories (Ambulatory,Hospitalization,etc) answer Yes.  If you wish to list visits for only one service category enter NO." D ^DIR K DIR
  1.  G:$D(DIRUT) DATES
  1.  I Y=1 G FAC
  1. SC1 ;enter sc
  1.  S X="SERVICE CATEGORY",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" G DATES
  1.  D PEP^AMQQGTX0(+Y,"APCLSCT(")
  1.  I '$D(APCLSCT) G SC
  1.  I $D(APCLSCT("*")) K APCLSCT
  1. FAC ;
  1.  S APCLLOCT=""
  1.  S DIR(0)="S^A:ALL Locations/Facilities;O:ONE Location/Facility",DIR("A")="Include Visits to Which Location/Facilities",DIR("B")="A"
  1.  S DIR("A")="Enter a code indicating what LOCATIONS/FACILITIES are of interest",DIR("B")="O" K DA D ^DIR K DIR,DA
  1.  G:$D(DIRUT) DATES
  1.  S APCLLOCT=Y
  1.  I APCLLOCT="A" G OPCODE
  1.  D O
  1.  G:APCLLOC="" FAC
  1. OPCODE ;
  1.  S APCLICD=""
  1.  K ^XTMP("APCLOP1",APCLJ,APCLH,"ICD")
  1.  S DIR(0)="S^A:ALL Procedures;S:Selected Set of ICD Procedure codes",DIR("A")="Include which ICD Procedurs in the Report"
  1.  S DIR("A")="Enter a code indicating what ICD Procedure codes are of interest",DIR("B")="A" K DA D ^DIR K DIR,DA
  1.  G:$D(DIRUT) FAC
  1.  S APCLICD=Y
  1.  I APCLICD="A" G LIST
  1.  D ^XBFMK
  1.  S X="PROCEDURE (MEDICAL)",DIC="^AMQQ(5,",DIC(0)="",DIC("S")="I $P(^(0),U,14)"
  1.  D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" G EOJ
  1.  D PEP^AMQQGTX0(+Y,"^XTMP(""APCLOP1"",APCLJ,APCLH,""ICD"",")
  1.  I '$D(^XTMP("APCLOP1",APCLJ,APCLH,"ICD")) G FAC
  1.  I $D(^XTMP("APCLOP1",APCLJ,APCLH,"ICD","*")) S APCLICD="A"
  1. LIST ;
  1.  S APCLLIST=0 W ! S DIR(0)="YO",DIR("A")="Do you want a List of all the procedures in addition to the tally",DIR("B")="Yes"
  1.  S DIR("?")="If you wish to include a list of all procedures, enter yes" D ^DIR K DIR
  1.  G:$D(DIRUT) OPCODE
  1.  S APCLLIST=Y
  1. ZIS ;
  1. DEMO ;
  1.  D DEMOCHK^APCLUTL(.APCLDEMO)
  1.  I APCLDEMO=-1 G LIST
  1.  S XBRP="PRINT^APCLOP1",XBRC="PROC^APCLOP1",XBRX="EOJ^APCLOP1",XBNS="APCL"
  1.  D ^XBDBQUE
  1.  D EOJ
  1.  Q
  1. EOJ ;
  1.  D EN^XBVK("APCL")
  1.  D ^XBFMK
  1.  Q
  1. PROC ;
  1.  S APCLCNTV=0,APCLCNTP=0,APCLCNTD=0 K APCLOPRV,APCLOPRC
  1.  ; Run by visit date
  1.  S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X
  1.  S APCLODAT=APCLSD_".9999" F  S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED)  D V1
  1.  Q
  1. V1 ;
  1.  S APCLVIEN="" F  S APCLVIEN=$O(^AUPNVSIT("B",APCLODAT,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN  I $D(^AUPNVSIT(APCLVIEN,0)),$P(^(0),U,9),'$P(^(0),U,11) D PROC1
  1.  Q
  1. PROC1 ;
  1.  Q:'$D(^AUPNVPRC("AD",APCLVIEN))  ;no procedures
  1.  S X=$P(^AUPNVSIT(APCLVIEN,0),U,7)
  1.  Q:X=""
  1.  I $D(APCLSCT),'$D(APCLSCT(X)) Q
  1.  S X=$P(^AUPNVSIT(APCLVIEN,0),U,6) Q:X=""
  1.  S X=$P(^AUPNVSIT(APCLVIEN,0),U,5) Q:X=""  Q:$$DEMO^APCLUTL(X,$G(APCLDEMO))
  1.  I APCLLOCT="O" Q:X'=APCLLOC
  1.  ;loop through procedures
  1.  S APCLPIEN=0 F  S APCLPIEN=$O(^AUPNVPRC("AD",APCLVIEN,APCLPIEN)) Q:APCLPIEN'=+APCLPIEN  D
  1.  .S APCLIPTR=0 S APCLIPTR=$P(^AUPNVPRC(APCLPIEN,0),U) Q:'APCLIPTR  Q:'$D(^ICD0(APCLIPTR,0))
  1.  .I APCLICD="S",'$D(^XTMP("APCLOP1",APCLJ,APCLH,"ICD",APCLIPTR)) Q
  1.  .S ^XTMP("APCLOP1",APCLJ,APCLH,"VISITS",$P($P(^AUPNVSIT(APCLVIEN,0),U),"."),APCLVIEN,APCLPIEN)=""
  1.  .S X=$P(^AUPNVPRC(APCLPIEN,0),U,11)
  1.  .I X="" S X="UNKNOWN",Y="??" I 1
  1.  .E  S Y=X,X=$P(^VA(200,X,0),U)
  1.  .;S P=$P(^ICD0(APCLIPTR,0),U)  ;cmi/anch/maw 9/12/2007 orig line
  1.  .S P=$P($$ICDOP^ICDEX(APCLIPTR,,,"I"),U,2) ;cmi/anch/maw 9/12/2007 csv
  1.  .S APCLOPRV(X,Y,P,APCLIPTR)=$G(APCLOPRV(X,Y,P,APCLIPTR))+1,APCLOPRV(X,Y,"TOTAL")=$G(APCLOPRV(X,Y,"TOTAL"))+1
  1.  .S APCLCNTP=APCLCNTP+1
  1.  .S APCLOPRC(P,APCLIPTR,X,Y)=$G(APCLOPRC(P,APCLIPTR,X,Y))+1,APCLOPRC(P,APCLIPTR,"TOTAL")=$G(APCLOPRC(P,APCLIPTR,"TOTAL"))+1
  1.  Q
  1.  ;
  1. PRINT ;EP - called from xbdbque
  1.  S APCLPG=0 K APCLQUIT
  1.  I '$D(^XTMP("APCLOP1",APCLJ,APCLH)) D HEADER W !!,"No data to report.",! G DONE
  1.  D HEADER
  1.  W !,$TR($J("",80)," ","-")
  1.  W !!,"Total # of Procedures: ",?50,$$PAD($$C(APCLCNTP,0,7),7)
  1.  W !!,"Tally BY Operating Providers:"
  1.  W !?3,"Operating Provider",?50,"# of Procedures"
  1.  S APCLP=0 F  S APCLP=$O(APCLOPRV(APCLP)) Q:APCLP=""!($D(APCLQUIT))  D
  1.  .I $Y>(IOSL-6) D HEADER
  1.  .W !!,APCLP
  1.  .S APCLY="" F  S APCLY=$O(APCLOPRV(APCLP,APCLY)) Q:APCLY=""!($D(APCLQUIT))  D
  1.  ..S APCLX="" F  S APCLX=$O(APCLOPRV(APCLP,APCLY,APCLX)) Q:APCLX=""!($D(APCLQUIT))  D
  1.  ...Q:APCLX="TOTAL"
  1.  ...S APCLI=$O(APCLOPRV(APCLP,APCLY,APCLX,0))
  1.  ...;W !?5,APCLX,?12,$E($P(^ICD0(APCLI,0),U,4),1,25),?50,$$PAD($$C(APCLOPRV(APCLP,APCLY,APCLX,APCLI),0,7),7)  ;cmi/anch/maw 9/12/2007 orig line
  1.  ...W !?5,APCLX,?15,$E($P($$ICDOP^ICDEX(APCLI,,,"I"),U,5),1,25),?50,$$PAD($$C(APCLOPRV(APCLP,APCLY,APCLX,APCLI),0,7),7)  ;cmi/anch/maw 9/12/2007 csv
  1.  ..W !?3,"Total # Procedures for ",$E(APCLP,1,20),?50,$$PAD($$C(APCLOPRV(APCLP,APCLY,"TOTAL"),0,7),7)
  1.  .Q
  1.  D HEADER
  1.  W !,$TR($J("",80)," ","-")
  1.  W !!,"Tally BY ICD Procedure Code:"
  1.  W !?3,"Procedure",?50,"# of Procedures"
  1.  S APCLP="" F  S APCLP=$O(APCLOPRC(APCLP)) Q:APCLP=""!($D(APCLQUIT))  D
  1.  .I $Y>(IOSL-6) D HEADER
  1.  .S APCLI=$O(APCLOPRC(APCLP,0))
  1.  .;W !!,APCLP,?7,$E($P(^ICD0(APCLI,0),U,4),1,25),?50,$$PAD($$C(APCLOPRC(APCLP,APCLI,"TOTAL"),0,7),7)  ;cmi/anch/maw 9/12/2007 orig line
  1.  .W !!,APCLP,?9,$E($P($$ICDOP^ICDEX(APCLI,,,"I"),U,5),1,25),?50,$$PAD($$C(APCLOPRC(APCLP,APCLI,"TOTAL"),0,7),7)  ;cmi/anch/maw 9/12/2007 csv
  1.  .S APCLY="" F  S APCLY=$O(APCLOPRC(APCLP,APCLI,APCLY)) Q:APCLY=""!($D(APCLQUIT))  D
  1.  ..Q:APCLY="TOTAL"
  1.  ..S APCLX="" F  S APCLX=$O(APCLOPRC(APCLP,APCLI,APCLY,APCLX)) Q:APCLX=""!($D(APCLQUIT))  D
  1.  ...W !?5,APCLY,?50,$$PAD($$C(APCLOPRC(APCLP,APCLI,APCLY,APCLX),0,7),7)
  1.  ..;W !?3,"Total # Procedures for ",$E(APCLP,1,20),?50,$$PAD($$C(APCLOPRV(APCLP,APCLY,"TOTAL"),0,7),7)
  1.  .Q
  1.  I 'APCLLIST D DONE Q
  1.  D HEADER,H1
  1.  S APCLDATE=0 F  S APCLDATE=$O(^XTMP("APCLOP1",APCLJ,APCLH,"VISITS",APCLDATE)) Q:APCLDATE'=+APCLDATE!($D(APCLQUIT))  D P1
  1.  D DONE
  1.  Q
  1. P1 ;
  1.  S APCLV="" F  S APCLV=$O(^XTMP("APCLOP1",APCLJ,APCLH,"VISITS",APCLDATE,APCLV)) Q:APCLV=""!($D(APCLQUIT))  D
  1.  .S DFN=$P(^AUPNVSIT(APCLV,0),U,5)
  1.  .I $Y>(IOSL-4) D HEADER,H1
  1.  .W !,$E($P(^DPT(DFN,0),U),1,21),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$$FMTE^XLFDT($$DOB^AUPNPAT(DFN),5),?40,$$FMTE^XLFDT($P($P(^AUPNVSIT(APCLV,0),U),"."),5),?51,$P(^AUPNVSIT(APCLV,0),U,7)
  1.  .W ?53,$E($P(^AUTTLOC($P(^AUPNVSIT(APCLV,0),U,6),0),U,7),1,5)
  1.  .S APCLPIEN=0,C=0 F  S APCLPIEN=$O(^XTMP("APCLOP1",APCLJ,APCLH,"VISITS",APCLDATE,APCLV,APCLPIEN)) Q:APCLPIEN'=+APCLPIEN!($D(APCLQUIT))  D
  1.  ..S C=C+1 W:C>1 ! W ?58,$$VAL^XBDIQ1(9000010.08,APCLPIEN,.01),?68,$E($$VAL^XBDIQ1(9000010.08,APCLPIEN,.11),1,11)
  1.  Q
  1.  G:'APCLPG HEADER1
  1.  K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQUIT="" Q
  1. HEADER1 ;
  1.  W:$D(IOF) @IOF S APCLPG=APCLPG+1
  1.  W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCLPG,!
  1.  W !,$$CTR("***  PROCEDURE TALLY/LISTING  ***",80),!
  1.  S X="Visit Dates: "_$$FMTE^XLFDT(APCLBD)_" to "_$$FMTE^XLFDT(APCLED) W $$CTR(X,80),!
  1.  W "Service Categories: "
  1.  I '$D(APCLSCT) W "ALL"
  1.  I $D(APCLSCT) S X="" F  S X=$O(APCLSCT(X)) Q:X=""  W X," ;"
  1.  W !,"Procedures included in this report:"
  1.  I APCLICD="A" W "  ALL ICD PROCEDURES" Q
  1.  ;S C=0,X=0 F  S X=$O(^XTMP("APCLOP1",APCLJ,APCLH,"ICD",X)) Q:X'=+X!(C>50)  W " ",$P(^ICD0(X,0),U) S C=C+1  ;cmi/anch/maw 9/12/2007 orig line
  1.  S C=0,X=0 F  S X=$O(^XTMP("APCLOP1",APCLJ,APCLH,"ICD",X)) Q:X'=+X!(C>50)  W " ",$P($$ICDOP^ICDEX(X,,,"I"),U,2) S C=C+1  ;cmi/anch/maw 9/12/2007 csv
  1.  I C>50 W "  ....ETC"
  1.  Q
  1. H1 W !,"PATIENT NAME",?22,"HRN",?29,"DOB",?40,"VST DATE",?51,"SC",?54,"LOC",?58,"ICD",?68,"Operating Prov"
  1.  W !,$TR($J("",80)," ","-")
  1.  Q
  1. DONE ;
  1.  K ^XTMP("APCLOP1",APCLJ,APCLH)
  1.  D EOP
  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. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:IO'=IO(0)
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  W !
  1.  S DIR("A")="End of Report.  Press Enter",DIR(0)="E" D ^DIR
  1.  Q
  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. O ;one location
  1.  S APCLLOC=""
  1.  S DIC="^AUTTLOC(",DIC(0)="AEMQ",DIC("A")="Which LOCATION: " D ^DIC K DIC
  1.  I Y=-1 S APCLQ="" Q
  1.  S APCLLOC=+Y
  1.  Q
  1. C(X,X2,X3) ;
  1.  D COMMA^%DTC
  1.  Q $$STRIP^XLFSTR(X," ")
  1. PAD(D,L) ; -- SUBRTN to pad length of data
  1.  ; -- D=data L=length
  1.  S L=L-$L(D)
  1.  Q $E($$REPEAT^XLFSTR(" ",L),1,L)_D