APCLER2P.m

APCLER2P ; IHS/CMI/LAB - PRINT CLINIC VISITS ;

 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

 ;

 ;

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("APCLER2",APCLJOB,APCLBTH)) D HEAD W !,"No visits to report."  G END

 ;

SET ;

 D HEAD

 S APCLVDFN=0

 F  S APCLVDFN=$O(^XTMP("APCLER2",APCLJOB,APCLBTH,APCLVDFN)) Q:APCLVDFN=""!($D(APCLQUIT))  D SET2

END ;

 D DONE^APCLOSUT

 K ^XTMP("APCLER2",APCLJOB,APCLBTH)

 Q

SET2 ;

 S APCLVER=^XTMP("APCLER2",APCLJOB,APCLBTH,APCLVDFN)

 S APCLVREC=^AUPNVSIT(APCLVDFN,0)

 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 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,?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($$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,16)

PRINT2 ;

 S APCLVD=$E($P(^AUPNVSIT(APCLVER,0),U),4,5)_"/"_$E($P(^AUPNVSIT(APCLVER,0),U),6,7)_"/"_$E($P(^AUPNVSIT(APCLVER,0),U),2,3) S Y=$P(^AUPNVSIT(APCLVER,0),U) D DD^%DT S APCLVD=APCLVD_" "_$P(Y,"@",2)

 S APCLCLN=$S($P(^AUPNVSIT(APCLVER,0),U,8):$P(^DIC(40.7,$P(^AUPNVSIT(APCLVER,0),U,8),0),U,2),1:"--")

 S APCLFAC=$S($P(^AUPNVSIT(APCLVER,0),U,6):$P(^AUTTLOC($P(^AUPNVSIT(APCLVER,0),U,6),0),U,7),1:"--")

 I $Y>(IOSL-5) D HEAD Q:$D(APCLQUIT)

 W !?3,"ER Visit Information =>",?28,APCLVD,?45,APCLCLN,?49,APCLFAC S (APCLFRST,APCLP)=0

 F  S APCLP=$O(^AUPNVPOV("AD",APCLVER,APCLP)) Q:APCLP'=+APCLP  D

 .W:APCLFRST !

 .S APCLFRST=APCLFRST+1

 .W ?54,$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLP,0),U),0),U,2) W:$P(^AUPNVPOV(APCLP,0),U,4)]"" ?64,$E($$VAL^XBDIQ1(9000010.07,APCLP,.04),1,16)

 .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 !?25,"HOSPITAL ADMISSIONS AFTER ER VISIT"

 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

 ;

APCLER2P  ; IHS/CMI/LAB - PRINT CLINIC VISITS ;

 +1       ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

 +2       ;

 +3       ;

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("APCLER2",APCLJOB,APCLBTH))

               DO HEAD

               WRITE !,"No visits to report."

               GOTO END

 +5       ;

SET       ;

 +1        DO HEAD

 +2        SET APCLVDFN=0

 +3        FOR 

               SET APCLVDFN=$ORDER(^XTMP("APCLER2",APCLJOB,APCLBTH,APCLVDFN))

               IF APCLVDFN=""!($DATA(APCLQUIT))

                   QUIT 

               DO SET2

END       ;

 +1        DO DONE^APCLOSUT

 +2        KILL ^XTMP("APCLER2",APCLJOB,APCLBTH)

 +3        QUIT 

SET2      ;

 +1        SET APCLVER=^XTMP("APCLER2",APCLJOB,APCLBTH,APCLVDFN)

 +2        SET APCLVREC=^AUPNVSIT(APCLVDFN,0)

 +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 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,?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                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,16)

               End DoDot:1

PRINT2    ;

 +1        SET APCLVD=$EXTRACT($PIECE(^AUPNVSIT(APCLVER,0),U),4,5)_"/"_$EXTRACT($PIECE(^AUPNVSIT(APCLVER,0),U),6,7)_"/"_$EXTRACT($PIECE(^AUPNVSIT(APCLVER,0),U),2,3)

           SET Y=$PIECE(^AUPNVSIT(APCLVER,0),U)

           DO DD^%DT

           SET APCLVD=APCLVD_" "_$PIECE(Y,"@",2)

 +2        SET APCLCLN=$SELECT($PIECE(^AUPNVSIT(APCLVER,0),U,8):$PIECE(^DIC(40.7,$PIECE(^AUPNVSIT(APCLVER,0),U,8),0),U,2),1:"--")

 +3        SET APCLFAC=$SELECT($PIECE(^AUPNVSIT(APCLVER,0),U,6):$PIECE(^AUTTLOC($PIECE(^AUPNVSIT(APCLVER,0),U,6),0),U,7),1:"--")

 +4        IF $Y>(IOSL-5)

               DO HEAD

               IF $DATA(APCLQUIT)

                   QUIT 

 +5        WRITE !?3,"ER Visit Information =>",?28,APCLVD,?45,APCLCLN,?49,APCLFAC

           SET (APCLFRST,APCLP)=0

 +6        FOR 

               SET APCLP=$ORDER(^AUPNVPOV("AD",APCLVER,APCLP))

               IF APCLP'=+APCLP

                   QUIT 

               Begin DoDot:1

 +7                IF APCLFRST

                       WRITE !

 +8                SET APCLFRST=APCLFRST+1

 +9                WRITE ?54,$PIECE($$ICDDX^ICDEX($PIECE(^AUPNVPOV(APCLP,0),U),0),U,2)

                   IF $PIECE(^AUPNVPOV(APCLP,0),U,4)]""

                       WRITE ?64,$EXTRACT($$VAL^XBDIQ1(9000010.07,APCLP,.04),1,16)

 +10               QUIT 

               End DoDot:1

 +11       WRITE !

 +12       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 !?25,"HOSPITAL ADMISSIONS AFTER ER VISIT"

 +6        WRITE !?18,"VISITS DATES:  ",APCLBDD,"  TO  ",APCLEDD

 +7        WRITE !!?5,"NAME",?17,"HRCN",?28,"VISIT DATE&TIME",?45,"CLN",?49,"FAC",?54,"ICD",?64,"PROV NARRATIVE"

 +8        WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")

 +9        WRITE !

 +10       QUIT 

 +11      ;