Routine: APCLACC1

APCLACC1 ; IHS/CMI/LAB - process active user report ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;IHS/CMI/LAB - added template creation

 ;PRINT INDIAN PATIENT COUNTS FOR SERVICE UNIT

START ;

 K APCLSUP

 S APCL80D="--------------------------------------------------------------------------------" ;80 DASHES

 ;S:APCLFS="S" (APCLSUP,APCLSUN)=$P(^AUTTSU(APCLSU,0),U)

 I APCLFS="S" S X=0 F  S X=$O(APCLSU(X)) Q:X'=+X  S APCLSUP($P(^AUTTSU(X,0),U))=$P(^AUTTSU(X,0),U)

 ;I APCLFS="F" S APCLSUP=$P(^DIC(4,APCLSU,0),U),APCLSUN=$P(^AUTTSU(APCLSUF,0),U)

 I APCLFS="F" S X=0 F  S X=$O(APCLSU(X)) Q:X'=+X  S APCLSUP($P(^DIC(4,X,0),U))=$S($P(^AUTTLOC(X,0),U,5):$P(^AUTTSU($P(^AUTTLOC(X,0),U,5),0),U),1:"??")

 S (APCL1,APCL2,APCLPG)=0 D HEAD

 I APCLRPTT="T" D TEMPLATE G DONE

 S APCLMAJ=0 K APCLQUIT

 F I=0:0 S APCLMAJ=$O(^XTMP("APCLACC",APCLJOB,APCLBT,APCLMAJ)) Q:APCLMAJ=""!($D(APCLQUIT))  D MINOR

 G:$D(APCLQUIT) DONE

 I $Y>(IOSL-7) D HEAD G:$D(APCLQUIT) DONE

 W !!?50,"------",?67,"------",!

 W ?39,"Total:",?50,$J(APCL1,6),?67,$J(APCL2,6),!

DONE ;

 D DONE^APCLOSUT

 K ^XTMP("APCLACC",APCLJOB,APCLBT),^XTMP("APCLACCR",APCLJOB,APCLBT),^XTMP("APCLACC SU",APCLJOB,APCLBT)

MINOR ;

 I $Y>(IOSL-$S(APCLSUB=1:9,1:6)) D HEAD Q:$D(APCLQUIT)

 W !,APCLMAJ W:APCLSUB=1 !

 S APCLMIN=0 F  S APCLMIN=$O(^XTMP("APCLACC",APCLJOB,APCLBT,APCLMAJ,APCLMIN)) Q:APCLMIN=""!($D(APCLQUIT))  D MINOR1

 Q:$D(APCLQUIT)

 D MAJTOT

MINOR1 ;

 S:'$D(^XTMP("APCLACCR",APCLJOB,APCLBT,"SUBTOTAL",APCLMAJ)) ^XTMP("APCLACCR",APCLJOB,APCLBT,"SUBTOTAL",APCLMAJ)="0^0"

 F APCLI=1:1:2 S $P(^XTMP("APCLACCR",APCLJOB,APCLBT,"SUBTOTAL",APCLMAJ),U,APCLI)=$P(^XTMP("APCLACCR",APCLJOB,APCLBT,"SUBTOTAL",APCLMAJ),U,APCLI)+$P(^XTMP("APCLACC",APCLJOB,APCLBT,APCLMAJ,APCLMIN),U,APCLI)

 S APCLP=1 F APCLI=1:1:2 S APCLVAR="APCLT"_APCLI,@APCLVAR=$P(^XTMP("APCLACC",APCLJOB,APCLBT,APCLMAJ,APCLMIN),U,APCLP) S:@APCLVAR="" @APCLVAR=0 S APCLP=APCLP+1

 F APCLI=1:1:2 S APCLVAR1="APCL"_APCLI,APCLVAR2="APCLT"_APCLI S @APCLVAR1=@APCLVAR1+@APCLVAR2

 Q:APCLSUB'=1

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

 W !?5,$E(APCLMIN,1,45) F APCLI=1:1:2 S APCLVAR="APCLT"_APCLI S APCLT=$P("50,67",",",APCLI) W ?APCLT,$J((@APCLVAR),6)

MAJTOT ;print major sort totals

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

 G:APCLSUB'=1 MAJTOT1

 W !?50,"------",?67,"------",!

 W ?39,"Subtotal:"

MAJTOT1 S APCLP=1 F APCLI=50,67 W ?APCLI,$J($P(^XTMP("APCLACCR",APCLJOB,APCLBT,"SUBTOTAL",APCLMAJ),U,APCLP),6) S APCLP=APCLP+1

W !

TEMPLATE ;create template

 ;create search template

 K DD,D0,DO,DIC S DIC="^DIBT(",DIC(0)="LM",X="ACTIVE USERS AS OF "_$$FMTE^XLFDT(APCLFYE,"2E") D ^DIC K DIC,DA,D0,DD

 I Y=-1 W !!,"SEARCH TEMPLATE CREATION FAILED." Q

 K ^DIBT(+Y,1)

 S APCLSTMP=+Y

 S DIE="^DIBT(",DA=APCLSTMP,DR="2////"_DT_";3////M;4////9000001;5////"_DUZ_";6////M"

 D ^DIE

 K DIE,DA,DR S Y=0 F  S Y=$O(^XTMP("APCLACC",APCLJOB,APCLBT,"TEMPLATE PATIENTS",Y)) Q:Y'=+Y  S ^DIBT(APCLSTMP,1,Y)=""""

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 $P(^DIC(4,DUZ(2),0),U),?60,APCLDTP,?72,"Page ",APCLPG,!

 W !,"Registration and Active Patient Counts for ",$S(APCLIND=1:"Indian",1:"all")," Patients registered ",$S(APCLFS="F":"at ",1:"in ")

 S %="the following "_$S(APCLFS="F":"Facilities",1:"Service Units")_":"

 W !,%

 S %="",X="" F  S X=$O(APCLSUP(X)) Q:X=""  S %=%_"   "_X

 W !?((80-$L(%))/2),%

 W:APCLRPTT'="T" !,"The report is sorted by ",$S(APCLSORT="C":"Community of Residence",APCLSORT="T":"Tribe of Membership",1:"Service Unit of Residence"),$S(APCLSUB=1:" and by ",1:".")

 I $G(APCLSUB)=1,APCLRPTT'="T" W $S(APCLSORT="C":"Tribe of Membership.",1:"Community of Residence.")

W !

 W:APCLSSUR=0 !,"A '*' after the Community name indicates a Non-Service Unit Community.",!

 W:APCLSSUR=1 !,"Report includes only those patients who reside in a Service Unit Community.",!

 W "Active Patient were those seen between ",APCLFYBY," and ",APCLFYEY,".",!

 I APCLRPTT="T" W !!!,"***** SEARCH TEMPLATE 'ACTIVE USERS AS OF "_$$FMTE^XLFDT(APCLFYE,"2E")_"' HAS BEEN CREATED ****" Q

 W !,$S(APCLSORT="C":"Current Community of Residence",APCLSORT="T":"Tribe of Membership",1:"Service Unit of Residence"),?50,"Reg Pts Living",?67,"Active"

 W !,$S(APCLSUB=1&(APCLSORT="C"):"     Tribe of Membership",APCLSUB=1&(APCLSORT'="C"):"      Community of Residence",1:""),?50,"As of Today",?67,"Patients"

 W !,APCL80D

APCLACC1  ; IHS/CMI/LAB - process active user report ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;IHS/CMI/LAB - added template creation

 +3       ;PRINT INDIAN PATIENT COUNTS FOR SERVICE UNIT

START     ;

 +1        KILL APCLSUP

 +2       ;80 DASHES

           SET APCL80D="--------------------------------------------------------------------------------"

 +3       ;S:APCLFS="S" (APCLSUP,APCLSUN)=$P(^AUTTSU(APCLSU,0),U)

 +4        IF APCLFS="S"

               SET X=0

FOR

                   SET X=$ORDER(APCLSU(X))

                   IF X'=+X

                       QUIT

                   SET APCLSUP($PIECE(^AUTTSU(X,0),U))=$PIECE(^AUTTSU(X,0),U)

 +5       ;I APCLFS="F" S APCLSUP=$P(^DIC(4,APCLSU,0),U),APCLSUN=$P(^AUTTSU(APCLSUF,0),U)

 +6        IF APCLFS="F"

               SET X=0

FOR

                   SET X=$ORDER(APCLSU(X))

                   IF X'=+X

                       QUIT

                   SET APCLSUP($PIECE(^DIC(4,X,0),U))=$SELECT($PIECE(^AUTTLOC(X,0),U,5):$PIECE(^AUTTSU($PIECE(^AUTTLOC(X,0),U,5),0),U),1:"??")

 +7        SET (APCL1,APCL2,APCLPG)=0

           DO HEAD

 +8        IF APCLRPTT="T"

               DO TEMPLATE

               GOTO DONE

 +9        SET APCLMAJ=0

           KILL APCLQUIT

 +10       FOR I=0:0

               SET APCLMAJ=$ORDER(^XTMP("APCLACC",APCLJOB,APCLBT,APCLMAJ))

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

                   QUIT

               DO MINOR

 +11       IF $DATA(APCLQUIT)

               GOTO DONE

 +12       IF $Y>(IOSL-7)

               DO HEAD

               IF $DATA(APCLQUIT)

                   GOTO DONE

 +13       WRITE !!?50,"------",?67,"------",!

 +14       WRITE ?39,"Total:",?50,$JUSTIFY(APCL1,6),?67,$JUSTIFY(APCL2,6),!

DONE      ;

 +1        DO DONE^APCLOSUT

 +2        KILL ^XTMP("APCLACC",APCLJOB,APCLBT),^XTMP("APCLACCR",APCLJOB,APCLBT),^XTMP("APCLACC SU",APCLJOB,APCLBT)

 +3        QUIT

MINOR     ;

 +1        IF $Y>(IOSL-$SELECT(APCLSUB=1:9,1:6))

               DO HEAD

               IF $DATA(APCLQUIT)

                   QUIT

 +2        WRITE !,APCLMAJ

           IF APCLSUB=1

               WRITE !

 +3        SET APCLMIN=0

FOR

               SET APCLMIN=$ORDER(^XTMP("APCLACC",APCLJOB,APCLBT,APCLMAJ,APCLMIN))

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

                   QUIT

               DO MINOR1

 +4        IF $DATA(APCLQUIT)

               QUIT

 +5        DO MAJTOT

 +6        QUIT

MINOR1    ;

 +1        IF '$DATA(^XTMP("APCLACCR",APCLJOB,APCLBT,"SUBTOTAL",APCLMAJ))

               SET ^XTMP("APCLACCR",APCLJOB,APCLBT,"SUBTOTAL",APCLMAJ)="0^0"

 +2        FOR APCLI=1:1:2

               SET $PIECE(^XTMP("APCLACCR",APCLJOB,APCLBT,"SUBTOTAL",APCLMAJ),U,APCLI)=$PIECE(^XTMP("APCLACCR",APCLJOB,APCLBT,"SUBTOTAL",APCLMAJ),U,APCLI)+$PIECE(^XTMP("APCLACC",APCLJOB,APCLBT,APCLMAJ,APCLMIN),U,APCLI)

 +3        SET APCLP=1

           FOR APCLI=1:1:2

               SET APCLVAR="APCLT"_APCLI

               SET @APCLVAR=$PIECE(^XTMP("APCLACC",APCLJOB,APCLBT,APCLMAJ,APCLMIN),U,APCLP)

               IF @APCLVAR=""

                   SET @APCLVAR=0

               SET APCLP=APCLP+1

 +4        FOR APCLI=1:1:2

               SET APCLVAR1="APCL"_APCLI

               SET APCLVAR2="APCLT"_APCLI

               SET @APCLVAR1=@APCLVAR1+@APCLVAR2

 +5        IF APCLSUB'=1

               QUIT

 +6        IF $Y>(IOSL-6)

               DO HEAD

               IF $DATA(APCLQUIT)

                   QUIT

 +7        WRITE !?5,$EXTRACT(APCLMIN,1,45)

           FOR APCLI=1:1:2

               SET APCLVAR="APCLT"_APCLI

               SET APCLT=$PIECE("50,67",",",APCLI)

               WRITE ?APCLT,$JUSTIFY((@APCLVAR),6)

 +8        QUIT

MAJTOT    ;print major sort totals

 +1       ;I $Y>(IOSL-7) D HEAD Q:$D(APCLQUIT)

 +2        IF APCLSUB'=1

               GOTO MAJTOT1

 +3        WRITE !?50,"------",?67,"------",!

 +4        WRITE ?39,"Subtotal:"

MAJTOT1    SET APCLP=1

           FOR APCLI=50,67

               WRITE ?APCLI,$JUSTIFY($PIECE(^XTMP("APCLACCR",APCLJOB,APCLBT,"SUBTOTAL",APCLMAJ),U,APCLP),6)

               SET APCLP=APCLP+1

 +1        WRITE !

 +2        QUIT

TEMPLATE  ;create template

 +1       ;create search template

 +2        KILL DD,D0,DO,DIC

           SET DIC="^DIBT("

           SET DIC(0)="LM"

           SET X="ACTIVE USERS AS OF "_$$FMTE^XLFDT(APCLFYE,"2E")

           DO ^DIC

           KILL DIC,DA,D0,DD

 +3        IF Y=-1

               WRITE !!,"SEARCH TEMPLATE CREATION FAILED."

               QUIT

 +4        KILL ^DIBT(+Y,1)

 +5        SET APCLSTMP=+Y

 +6        SET DIE="^DIBT("

           SET DA=APCLSTMP

           SET DR="2////"_DT_";3////M;4////9000001;5////"_DUZ_";6////M"

 +7        DO ^DIE

 +8        KILL DIE,DA,DR

           SET Y=0

FOR

               SET Y=$ORDER(^XTMP("APCLACC",APCLJOB,APCLBT,"TEMPLATE PATIENTS",Y))

               IF Y'=+Y

                   QUIT

               SET ^DIBT(APCLSTMP,1,Y)=""""

 +9        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 $PIECE(^DIC(4,DUZ(2),0),U),?60,APCLDTP,?72,"Page ",APCLPG,!

 +3        WRITE !,"Registration and Active Patient Counts for ",$SELECT(APCLIND=1:"Indian",1:"all")," Patients registered ",$SELECT(APCLFS="F":"at ",1:"in ")

 +4        SET %="the following "_$SELECT(APCLFS="F":"Facilities",1:"Service Units")_":"

 +5        WRITE !,%

 +6        SET %=""

           SET X=""

FOR

               SET X=$ORDER(APCLSUP(X))

               IF X=""

                   QUIT

               SET %=%_"   "_X

 +7        WRITE !?((80-$LENGTH(%))/2),%

 +8        IF APCLRPTT'="T"

               WRITE !,"The report is sorted by ",$SELECT(APCLSORT="C":"Community of Residence",APCLSORT="T":"Tribe of Membership",1:"Service Unit of Residence"),$SELECT(APCLSUB=1:" and by ",1:".")

 +9        IF $GET(APCLSUB)=1

               IF APCLRPTT'="T"

                   WRITE $SELECT(APCLSORT="C":"Tribe of Membership.",1:"Community of Residence.")

 +10       WRITE !

 +11       IF APCLSSUR=0

               WRITE !,"A '*' after the Community name indicates a Non-Service Unit Community.",!

 +12       IF APCLSSUR=1

               WRITE !,"Report includes only those patients who reside in a Service Unit Community.",!

 +13       WRITE "Active Patient were those seen between ",APCLFYBY," and ",APCLFYEY,".",!

 +14       IF APCLRPTT="T"

               WRITE !!!,"***** SEARCH TEMPLATE 'ACTIVE USERS AS OF "_$$FMTE^XLFDT(APCLFYE,"2E")_"' HAS BEEN CREATED ****"

               QUIT

 +15       WRITE !,$SELECT(APCLSORT="C":"Current Community of Residence",APCLSORT="T":"Tribe of Membership",1:"Service Unit of Residence"),?50,"Reg Pts Living",?67,"Active"

 +16       WRITE !,$SELECT(APCLSUB=1&(APCLSORT="C"):"     Tribe of Membership",APCLSUB=1&(APCLSORT'="C"):"      Community of Residence",1:""),?50,"As of Today",?67,"Patients"

 +17       WRITE !,APCL80D

 +18       QUIT

APCLACC1.m