APCLCP9P.m

APCLCP9P ; IHS/CMI/LAB - print apc report by prov disc ;

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

START ;

 S APCL80S="-------------------------------------------------------------------------------"

 D NOW^%DTC S Y=X D DD^%DT S APCLDT=Y

 S Y=APCLBD D DD^%DT S APCLBDD=Y S Y=APCLED D DD^%DT S APCLEDD=Y

 S (APCLPG,APCLNUM,APCLCNT)=0

 K APCLQUIT

 D HEAD,SUBHEAD

 F  S APCLNUM=$O(^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,"TOP TEN",APCLNUM)) Q:APCLNUM'=+APCLNUM!(APCLCNT=10)!($D(APCLQUIT))  D NUM

DONE ;

 D DONE^APCLOSUT

 K ^XTMP("APCLCP9",APCLJOB,APCLBT)

 Q

NUM ;

 S APCLCODE="" F  S APCLCODE=$O(^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,"TOP TEN",APCLNUM,APCLCODE)) Q:APCLCODE=""  D P

 Q

P ;

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

 S G=APCLGLOB_APCLCODE_")"

 I APCLGLOB="^ICD9(" W !,$E($P($$ICDDX^ICDEX(APCLCODE),U,4),1,26),?42,$J($S($D(^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,APCLCODE,"TOTAL")):^("TOTAL"),1:0),7) I 1

 E  W !,$E($P(@G@(0),U,APCLPIEC),1,26),?42,$J($S($D(^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,APCLCODE,"TOTAL")):^("TOTAL"),1:0),7)

 S APCLCNT=APCLCNT+1

 Q

SUBHEAD ;

 Q:$D(APCLQUIT)

 S APCLLENG=$L($P(^AUTTSU(APCLSU,0),U))

 W ?(80-(15+APCLLENG)/2),"SERVICE UNIT:  ",$P(^AUTTSU(APCLSUF,0),U),!

 W !,"PRIMARY DX",?38,"TOTAL PATIENT CONTACTS"

 W !,APCL80S,!

 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 !

 W APCLDT,?72,"Page ",APCLPG,!

 S APCLLENG=$L($P(^APCLACTG(APCLACTG,0),U))

 W ?(80-(46+APCLLENG)/2),"TOP TEN PRIMARY DX REPORT BY SERVICE UNIT ",$P(^APCLACTG(APCLACTG,0),U)," STAFF",!

 W ?18,"VISIT DATES:  ",APCLBDD,"  TO  ",APCLEDD,!

 S X="" I '$D(APCLCLN) S X="All Clinics"

 I $D(APCLCLN) S X="Clinics: " S Y=0 F  S Y=$O(APCLCLN(Y)) Q:Y'=+Y  S X=X_$E($P(^DIC(40.7,Y,0),U),1,10)_"; "

 W $$CTR^APCLCP1P(X),!

 Q

APCLCP9P  ; IHS/CMI/LAB - print apc report by prov disc ;

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

START     ;

 +1        SET APCL80S="-------------------------------------------------------------------------------"

 +2        DO NOW^%DTC

           SET Y=X

           DO DD^%DT

           SET APCLDT=Y

 +3        SET Y=APCLBD

           DO DD^%DT

           SET APCLBDD=Y

           SET Y=APCLED

           DO DD^%DT

           SET APCLEDD=Y

 +4        SET (APCLPG,APCLNUM,APCLCNT)=0

 +5        KILL APCLQUIT

 +6        DO HEAD

           DO SUBHEAD

 +7        FOR 

               SET APCLNUM=$ORDER(^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,"TOP TEN",APCLNUM))

               IF APCLNUM'=+APCLNUM!(APCLCNT=10)!($DATA(APCLQUIT))

                   QUIT 

               DO NUM

DONE      ;

 +1        DO DONE^APCLOSUT

 +2        KILL ^XTMP("APCLCP9",APCLJOB,APCLBT)

 +3        QUIT 

NUM       ;

 +1        SET APCLCODE=""

           FOR 

               SET APCLCODE=$ORDER(^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,"TOP TEN",APCLNUM,APCLCODE))

               IF APCLCODE=""

                   QUIT 

               DO P

 +2        QUIT 

P         ;

 +1        IF $Y>(IOSL-5)

               DO HEAD

               DO SUBHEAD

               IF $DATA(APCLQUIT)

                   QUIT 

 +2        SET G=APCLGLOB_APCLCODE_")"

 +3        IF APCLGLOB="^ICD9("

               WRITE !,$EXTRACT($PIECE($$ICDDX^ICDEX(APCLCODE),U,4),1,26),?42,$JUSTIFY($SELECT($DATA(^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,APCLCODE,"TOTAL")):^("TOTAL"),1:0),7)

               IF 1

 +4       IF '$TEST

               WRITE !,$EXTRACT($PIECE(@G@(0),U,APCLPIEC),1,26),?42,$JUSTIFY($SELECT($DATA(^XTMP("APCLCP9",APCLJOB,APCLBT,APCLSUF,APCLCODE,"TOTAL")):^("TOTAL"),1:0),7)

 +5        SET APCLCNT=APCLCNT+1

 +6        QUIT 

SUBHEAD   ;

 +1        IF $DATA(APCLQUIT)

               QUIT 

 +2        SET APCLLENG=$LENGTH($PIECE(^AUTTSU(APCLSU,0),U))

 +3        WRITE ?(80-(15+APCLLENG)/2),"SERVICE UNIT:  ",$PIECE(^AUTTSU(APCLSUF,0),U),!

 +4        WRITE !,"PRIMARY DX",?38,"TOTAL PATIENT CONTACTS"

 +5        WRITE !,APCL80S,!

 +6        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        WRITE APCLDT,?72,"Page ",APCLPG,!

 +4        SET APCLLENG=$LENGTH($PIECE(^APCLACTG(APCLACTG,0),U))

 +5        WRITE ?(80-(46+APCLLENG)/2),"TOP TEN PRIMARY DX REPORT BY SERVICE UNIT ",$PIECE(^APCLACTG(APCLACTG,0),U)," STAFF",!

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

 +7        SET X=""

           IF '$DATA(APCLCLN)

               SET X="All Clinics"

 +8        IF $DATA(APCLCLN)

               SET X="Clinics: "

               SET Y=0

               FOR 

                   SET Y=$ORDER(APCLCLN(Y))

                   IF Y'=+Y

                       QUIT 

                   SET X=X_$EXTRACT($PIECE(^DIC(40.7,Y,0),U),1,10)_"; "

 +9        WRITE $$CTR^APCLCP1P(X),!

 +10       QUIT