- APCLER1P ; 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 APCLDT=$$FMTE^XLFDT(DT)
- S Y=APCLBD D DD^%DT S APCLBDD=Y S Y=APCLED D DD^%DT S APCLEDD=Y
- S APCLPG=0
- I '$D(^XTMP("APCLER1",APCLJOB,APCLBTH)) D HEAD W !,"No visits to report." G END
- ;
- SET ;
- D HEAD
- S APCLVDFN=0
- S DFN=0 F S DFN=$O(^XTMP("APCLER1",APCLJOB,APCLBTH,DFN)) Q:DFN'=+DFN!($D(APCLQUIT)) D
- .S APCLVDFN=0 F S APCLVDFN=$O(^XTMP("APCLER1",APCLJOB,APCLBTH,DFN,APCLVDFN)) Q:APCLVDFN=""!($D(APCLQUIT)) D SET2
- END ;
- D DONE^APCLOSUT
- K ^XTMP("APCLER1",APCLJOB,APCLBTH)
- Q
- SET2 ;
- S APCLVREC=^AUPNVSIT(APCLVDFN,0)
- I $G(APCLLOC)]"",$D(^AUPNPAT($P(APCLVREC,U,5),41,APCLLOC,0)) S APCLHRCN=$J($P(^AUTTLOC(APCLLOC,0),U,7),4)_" "_$P(^AUPNPAT($P(APCLVREC,U,5),41,APCLLOC,0),U,2) G PRN
- S APCLHRCN=$S($D(^AUPNPAT($P(APCLVREC,U,5),41,DUZ(2),0)):$J($P(^AUTTLOC(DUZ(2),0),U,7),4)_" "_$P(^AUPNPAT($P(APCLVREC,U,5),41,DUZ(2),0),U,2),1:"<NONE>")
- PRN ;
- S APCLNAME=$E($P(^DPT($P(APCLVREC,U,5),0),U),1,15)
- K ^UTILITY("DIQ1",$J) S DIC=9000001,DA=$P(APCLVREC,U,5),DR=1102.99 D EN^DIQ1
- S APCLAGE=$G(^UTILITY("DIQ1",$J,9000001,$P(APCLVREC,U,5),1102.99)) K ^UTILITY("DIQ1",$J)
- S APCLVD=$E($P(APCLVREC,U),4,5)_"/"_$E($P(APCLVREC,U),6,7)_"/"_$E($P(APCLVREC,U),2,3) S Y=$P(APCLVREC,U) D DD^%DT S APCLVD=APCLVD_" "_$P(Y,"@",2)
- S APCLCLNP=$P(^DIC(40.7,$P(APCLVREC,U,8),0),U,2)
- S APCLFAC=$P(^AUTTLOC($P(APCLVREC,U,6),0),U,7)
- PRINT1 ;
- I $Y>(IOSL-5) D HEAD Q:$D(APCLQUIT)
- W !,APCLNAME,?16,APCLHRCN,?28,APCLVD,?45,APCLCLNP,?49,APCLFAC 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,19) ;cmi/anch/maw 9/10/2007 csv
- .Q
- PRINT2 ;
- S APCLV=0 F S APCLV=$O(^XTMP("APCLER1",APCLJOB,APCLBTH,DFN,APCLVDFN,APCLV)) Q:APCLV=""!($D(APCLQUIT)) S APCLDFN=0 D
- .S APCLVD=$E($P(^AUPNVSIT(APCLV,0),U),4,5)_"/"_$E($P(^AUPNVSIT(APCLV,0),U),6,7)_"/"_$E($P(^AUPNVSIT(APCLV,0),U),2,3) S Y=$P(^AUPNVSIT(APCLV,0),U) D DD^%DT S APCLVD=APCLVD_" "_$P(Y,"@",2)
- .S APCLCLNP=$S($P(^AUPNVSIT(APCLV,0),U,8):$P(^DIC(40.7,$P(^AUPNVSIT(APCLV,0),U,8),0),U,2),1:"--")
- .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 !,?28,APCLVD,?45,APCLCLNP,?49,APCLFAC 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
- CTR(X,Y) ;EP - Center X in a field Y wide.
- Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
- ;----------
- 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 !?25,"ER VISITS AFTER CLINIC VISITS"
- S X="ER VISITS WITHIN "_$S(APCLHR=7:"72 HOURS",1:"48 HOURS")_" AFTER CLINIC VISITS" W !,$$CTR(X,80)
- I APCLCLN S X="RETURNS FROM CLINIC: "_$P(^DIC(40.7,APCLCLN,0),U) W !,$$CTR(X)
- I APCLPROV S X="RETURNS FROM PROVIDER: "_$P(^VA(200,APCLPROV,0),U) W !,$$CTR(X)
- W !?18,"VISITS DATES: ",APCLBDD," TO ",APCLEDD
- W !!?5,"NAME",?17,"HRCN",?28,"VISIT DATE&TIME",?45,"CLN",?49,"FAC",?54,"ICD",?64,"PROV NARRATIVE"
- W !,$TR($J("",80)," ","-")
- W !
- Q
- ;
- APCLER1P ; 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 APCLDT=$$FMTE^XLFDT(DT)
- +2 SET Y=APCLBD
- DO DD^%DT
- SET APCLBDD=Y
- SET Y=APCLED
- DO DD^%DT
- SET APCLEDD=Y
- +3 SET APCLPG=0
- +4 IF '$DATA(^XTMP("APCLER1",APCLJOB,APCLBTH))
- DO HEAD
- WRITE !,"No visits to report."
- GOTO END
- +5 ;
- SET ;
- +1 DO HEAD
- +2 SET APCLVDFN=0
- +3 SET DFN=0
- FOR
- SET DFN=$ORDER(^XTMP("APCLER1",APCLJOB,APCLBTH,DFN))
- IF DFN'=+DFN!($DATA(APCLQUIT))
- QUIT
- Begin DoDot:1
- +4 SET APCLVDFN=0
- FOR
- SET APCLVDFN=$ORDER(^XTMP("APCLER1",APCLJOB,APCLBTH,DFN,APCLVDFN))
- IF APCLVDFN=""!($DATA(APCLQUIT))
- QUIT
- DO SET2
- End DoDot:1
- END ;
- +1 DO DONE^APCLOSUT
- +2 KILL ^XTMP("APCLER1",APCLJOB,APCLBTH)
- +3 QUIT
- SET2 ;
- +1 SET APCLVREC=^AUPNVSIT(APCLVDFN,0)
- +2 IF $GET(APCLLOC)]""
- IF $DATA(^AUPNPAT($PIECE(APCLVREC,U,5),41,APCLLOC,0))
- SET APCLHRCN=$JUSTIFY($PIECE(^AUTTLOC(APCLLOC,0),U,7),4)_" "_$PIECE(^AUPNPAT($PIECE(APCLVREC,U,5),41,APCLLOC,0),U,2)
- GOTO PRN
- +3 SET APCLHRCN=$SELECT($DATA(^AUPNPAT($PIECE(APCLVREC,U,5),41,DUZ(2),0)):$JUSTIFY($PIECE(^AUTTLOC(DUZ(2),0),U,7),4)_" "_$PIECE(^AUPNPAT($PIECE(APCLVREC,U,5),41,DUZ(2),0),U,2),1:"<NONE>")
- PRN ;
- +1 SET APCLNAME=$EXTRACT($PIECE(^DPT($PIECE(APCLVREC,U,5),0),U),1,15)
- +2 KILL ^UTILITY("DIQ1",$JOB)
- SET DIC=9000001
- SET DA=$PIECE(APCLVREC,U,5)
- SET DR=1102.99
- DO EN^DIQ1
- +3 SET APCLAGE=$GET(^UTILITY("DIQ1",$JOB,9000001,$PIECE(APCLVREC,U,5),1102.99))
- KILL ^UTILITY("DIQ1",$JOB)
- +4 SET APCLVD=$EXTRACT($PIECE(APCLVREC,U),4,5)_"/"_$EXTRACT($PIECE(APCLVREC,U),6,7)_"/"_$EXTRACT($PIECE(APCLVREC,U),2,3)
- SET Y=$PIECE(APCLVREC,U)
- DO DD^%DT
- SET APCLVD=APCLVD_" "_$PIECE(Y,"@",2)
- +5 SET APCLCLNP=$PIECE(^DIC(40.7,$PIECE(APCLVREC,U,8),0),U,2)
- +6 SET APCLFAC=$PIECE(^AUTTLOC($PIECE(APCLVREC,U,6),0),U,7)
- PRINT1 ;
- +1 IF $Y>(IOSL-5)
- DO HEAD
- IF $DATA(APCLQUIT)
- QUIT
- +2 WRITE !,APCLNAME,?16,APCLHRCN,?28,APCLVD,?45,APCLCLNP,?49,APCLFAC
- 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,19)
- +8 QUIT
- End DoDot:1
- PRINT2 ;
- +1 SET APCLV=0
- FOR
- SET APCLV=$ORDER(^XTMP("APCLER1",APCLJOB,APCLBTH,DFN,APCLVDFN,APCLV))
- IF APCLV=""!($DATA(APCLQUIT))
- QUIT
- SET APCLDFN=0
- Begin DoDot:1
- +2 SET APCLVD=$EXTRACT($PIECE(^AUPNVSIT(APCLV,0),U),4,5)_"/"_$EXTRACT($PIECE(^AUPNVSIT(APCLV,0),U),6,7)_"/"_$EXTRACT($PIECE(^AUPNVSIT(APCLV,0),U),2,3)
- SET Y=$PIECE(^AUPNVSIT(APCLV,0),U)
- DO DD^%DT
- SET APCLVD=APCLVD_" "_$PIECE(Y,"@",2)
- +3 SET APCLCLNP=$SELECT($PIECE(^AUPNVSIT(APCLV,0),U,8):$PIECE(^DIC(40.7,$PIECE(^AUPNVSIT(APCLV,0),U,8),0),U,2),1:"--")
- +4 SET APCLFAC=$SELECT($PIECE(^AUPNVSIT(APCLV,0),U,6):$PIECE(^AUTTLOC($PIECE(^AUPNVSIT(APCLV,0),U,6),0),U,7),1:"--")
- +5 IF $Y>(IOSL-5)
- DO HEAD
- IF $DATA(APCLQUIT)
- QUIT
- +6 WRITE !,?28,APCLVD,?45,APCLCLNP,?49,APCLFAC
- SET (APCLFRST,APCLP)=0
- +7 FOR
- SET APCLP=$ORDER(^AUPNVPOV("AD",APCLV,APCLP))
- IF APCLP'=+APCLP
- QUIT
- Begin DoDot:2
- +8 IF APCLFRST
- WRITE !
- +9 SET APCLFRST=APCLFRST+1
- +10 ;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
- +11 ;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)
- +12 QUIT
- End DoDot:2
- +13 QUIT
- End DoDot:1
- +14 WRITE !
- +15 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 ;----------
- 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 ;W !?25,"ER VISITS AFTER CLINIC VISITS"
- +6 SET X="ER VISITS WITHIN "_$SELECT(APCLHR=7:"72 HOURS",1:"48 HOURS")_" AFTER CLINIC VISITS"
- WRITE !,$$CTR(X,80)
- +7 IF APCLCLN
- SET X="RETURNS FROM CLINIC: "_$PIECE(^DIC(40.7,APCLCLN,0),U)
- WRITE !,$$CTR(X)
- +8 IF APCLPROV
- SET X="RETURNS FROM PROVIDER: "_$PIECE(^VA(200,APCLPROV,0),U)
- WRITE !,$$CTR(X)
- +9 WRITE !?18,"VISITS DATES: ",APCLBDD," TO ",APCLEDD
- +10 WRITE !!?5,"NAME",?17,"HRCN",?28,"VISIT DATE&TIME",?45,"CLN",?49,"FAC",?54,"ICD",?64,"PROV NARRATIVE"
- +11 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
- +12 WRITE !
- +13 QUIT
- +14 ;
