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