- 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 ;
