APCLRADP ; IHS/CMI/LAB - PRINT CLINIC VISITS ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 9/10/2007 code set versioning in PRINT1,PRINT2
;
INIT ;
S APCLPG=0
I '$D(^XTMP("APCLRAD",APCLJOB,APCLBTH)) D HEAD W !,"No visits to report." G END
;
SET ;
D HEAD
S APCLVDFN=0
F S APCLVDFN=$O(^XTMP("APCLRAD",APCLJOB,APCLBTH,APCLVDFN)) Q:APCLVDFN=""!($D(APCLQUIT)) D SET2
END ;
D DONE^APCLOSUT
K ^XTMP("APCLRAD",APCLJOB,APCLBTH)
Q
SET2 ;
S APCLVREC=^AUPNVSIT(APCLVDFN,0),DFN=$P(APCLVREC,U,5)
PRINT1 ;
I $Y>(IOSL-5) D HEAD Q:$D(APCLQUIT)
W !,$E($P(^DPT(DFN,0),U),1,20),?22,$$HRN^AUPNPAT(DFN,$S(APCLLOC:APCLLOC,1:DUZ(2))),?29,$$VD^APCLV(APCLVDFN,"S"),?38,$P(^AUTTLOC($P(APCLVREC,U,6),0),U,7),?43,$E($$PRIMPROV^APCLV(APCLVDFN,"N"),1,10) S APCLFRST=0,APCLP=0
F S APCLP=$O(^AUPNVPOV("AD",APCLVDFN,APCLP)) Q:APCLP'=+APCLP D
.W:APCLFRST !
.S APCLFRST=APCLFRST+1
.;W ?54,$P(^ICD9($P(^AUPNVPOV(APCLP,0),U),0),U) W:$P(^AUPNVPOV(APCLP,0),U,4)]"" ?61,$E($P(^AUTNPOV($P(^AUPNVPOV(APCLP,0),U,4),0),U),1,19) ;cmi/anch/maw 9/10/2007 orig line
.W ?54,$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLP,0),U)),U,2) W:$P(^AUPNVPOV(APCLP,0),U,4)]"" ?64,$E($$VAL^XBDIQ1(9000010.07,APCLP,.04),1,15) ;cmi/anch/maw 9/10/2007 csv
.Q
PRINT2 ;
S APCLV=0 F S APCLV=$O(^XTMP("APCLRAD",APCLJOB,APCLBTH,APCLVDFN,APCLV)) Q:APCLV=""!($D(APCLQUIT)) S APCLDFN=0 D
.S APCLFAC=$S($P(^AUPNVSIT(APCLV,0),U,6):$P(^AUTTLOC($P(^AUPNVSIT(APCLV,0),U,6),0),U,7),1:"--")
.I $Y>(IOSL-5) D HEAD Q:$D(APCLQUIT)
.W !,?29,$$VD^APCLV(APCLV,"S"),?38,APCLFAC,?43,$E($$PRIMPROV^APCLV(APCLV,"N"),1,10) S (APCLFRST,APCLP)=0
.F S APCLP=$O(^AUPNVPOV("AD",APCLV,APCLP)) Q:APCLP'=+APCLP D
..W:APCLFRST !
..S APCLFRST=APCLFRST+1
..;W ?54,$P(^ICD9($P(^AUPNVPOV(APCLP,0),U),0),U) W:$P(^AUPNVPOV(APCLP,0),U,4)]"" ?61,$E($P(^AUTNPOV($P(^AUPNVPOV(APCLP,0),U,4),0),U),1,19) ;cmi/anch/maw 9/10/2007 orig line
..W ?54,$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLP,0),U)),U,2) W:$P(^AUPNVPOV(APCLP,0),U,4)]"" ?64,$E($$VAL^XBDIQ1(9000010.07,APCLP,.04),1,15) ;cmi/anch/maw 9/10/2007 csv
..Q
.Q
W !
Q
HEAD I 'APCLPG G HEAD1
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
HEAD1 ;
W:$D(IOF) @IOF S APCLPG=APCLPG+1
W !
S X=$P(^DIC(4,DUZ(2),0),U)
W !!,$P(^VA(200,DUZ,0),"^",2),?(80-$L(X)/2),X,?70,"Page ",APCLPG
W !?19,"READMISSIONS WITHIN 30 DAYS OF A DISCHARGE"
W !?18,"VISITS DATES: ",$$FMTE^XLFDT(APCLBD)," TO ",$$FMTE^XLFDT(APCLED)
W !!?5,"NAME",?22,"HRCN",?29,"ADM DATE",?38,"LOC",?43,"PROV",?54,"ICD",?64,"PROVIDER NARRATIVE"
W !,$TR($J("",80)," ","-")
W !
Q
;
APCLRADP ; IHS/CMI/LAB - PRINT CLINIC VISITS ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in PRINT1,PRINT2
+4 ;
INIT ;
+1 SET APCLPG=0
+2 IF '$DATA(^XTMP("APCLRAD",APCLJOB,APCLBTH))
DO HEAD
WRITE !,"No visits to report."
GOTO END
+3 ;
SET ;
+1 DO HEAD
+2 SET APCLVDFN=0
+3 FOR
SET APCLVDFN=$ORDER(^XTMP("APCLRAD",APCLJOB,APCLBTH,APCLVDFN))
IF APCLVDFN=""!($DATA(APCLQUIT))
QUIT
DO SET2
END ;
+1 DO DONE^APCLOSUT
+2 KILL ^XTMP("APCLRAD",APCLJOB,APCLBTH)
+3 QUIT
SET2 ;
+1 SET APCLVREC=^AUPNVSIT(APCLVDFN,0)
SET DFN=$PIECE(APCLVREC,U,5)
PRINT1 ;
+1 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+2 WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,20),?22,$$HRN^AUPNPAT(DFN,$SELECT(APCLLOC:APCLLOC,1:DUZ(2))),?29,$$VD^APCLV(APCLVDFN,"S"),?38,$PIECE(^AUTTLOC($PIECE(APCLVREC,U,6),0),U,7),?43,$EXTRACT($$PRIMPROV^APCLV(APCLVDFN,"N"),1,10)
SET APCLFRST=0
SET APCLP=0
+3 FOR
SET APCLP=$ORDER(^AUPNVPOV("AD",APCLVDFN,APCLP))
IF APCLP'=+APCLP
QUIT
Begin DoDot:1
+4 IF APCLFRST
WRITE !
+5 SET APCLFRST=APCLFRST+1
+6 ;W ?54,$P(^ICD9($P(^AUPNVPOV(APCLP,0),U),0),U) W:$P(^AUPNVPOV(APCLP,0),U,4)]"" ?61,$E($P(^AUTNPOV($P(^AUPNVPOV(APCLP,0),U,4),0),U),1,19) ;cmi/anch/maw 9/10/2007 orig line
+7 ;cmi/anch/maw 9/10/2007 csv
WRITE ?54,$PIECE($$ICDDX^ICDEX($PIECE(^AUPNVPOV(APCLP,0),U)),U,2)
IF $PIECE(^AUPNVPOV(APCLP,0),U,4)]""
WRITE ?64,$EXTRACT($$VAL^XBDIQ1(9000010.07,APCLP,.04),1,15)
+8 QUIT
End DoDot:1
PRINT2 ;
+1 SET APCLV=0
FOR
SET APCLV=$ORDER(^XTMP("APCLRAD",APCLJOB,APCLBTH,APCLVDFN,APCLV))
IF APCLV=""!($DATA(APCLQUIT))
QUIT
SET APCLDFN=0
Begin DoDot:1
+2 SET APCLFAC=$SELECT($PIECE(^AUPNVSIT(APCLV,0),U,6):$PIECE(^AUTTLOC($PIECE(^AUPNVSIT(APCLV,0),U,6),0),U,7),1:"--")
+3 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+4 WRITE !,?29,$$VD^APCLV(APCLV,"S"),?38,APCLFAC,?43,$EXTRACT($$PRIMPROV^APCLV(APCLV,"N"),1,10)
SET (APCLFRST,APCLP)=0
+5 FOR
SET APCLP=$ORDER(^AUPNVPOV("AD",APCLV,APCLP))
IF APCLP'=+APCLP
QUIT
Begin DoDot:2
+6 IF APCLFRST
WRITE !
+7 SET APCLFRST=APCLFRST+1
+8 ;W ?54,$P(^ICD9($P(^AUPNVPOV(APCLP,0),U),0),U) W:$P(^AUPNVPOV(APCLP,0),U,4)]"" ?61,$E($P(^AUTNPOV($P(^AUPNVPOV(APCLP,0),U,4),0),U),1,19) ;cmi/anch/maw 9/10/2007 orig line
+9 ;cmi/anch/maw 9/10/2007 csv
WRITE ?54,$PIECE($$ICDDX^ICDEX($PIECE(^AUPNVPOV(APCLP,0),U)),U,2)
IF $PIECE(^AUPNVPOV(APCLP,0),U,4)]""
WRITE ?64,$EXTRACT($$VAL^XBDIQ1(9000010.07,APCLP,.04),1,15)
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 WRITE !
+13 QUIT
HEAD IF 'APCLPG
GOTO HEAD1
+1 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
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET APCLPG=APCLPG+1
+2 WRITE !
+3 SET X=$PIECE(^DIC(4,DUZ(2),0),U)
+4 WRITE !!,$PIECE(^VA(200,DUZ,0),"^",2),?(80-$LENGTH(X)/2),X,?70,"Page ",APCLPG
+5 WRITE !?19,"READMISSIONS WITHIN 30 DAYS OF A DISCHARGE"
+6 WRITE !?18,"VISITS DATES: ",$$FMTE^XLFDT(APCLBD)," TO ",$$FMTE^XLFDT(APCLED)
+7 WRITE !!?5,"NAME",?22,"HRCN",?29,"ADM DATE",?38,"LOC",?43,"PROV",?54,"ICD",?64,"PROVIDER NARRATIVE"
+8 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+9 WRITE !
+10 QUIT
+11 ;
