APCLDP1P.m

APCLDP1P ; IHS/CMI/LAB - print active client list ;

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

 ;

 ;cmi/anch/maw 9/10/2007 code set versioning in VSTS

 ;

PRINT ;

START ;

 S APCL80D="-------------------------------------------------------------------------------"

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

 S APCLPG=0

 I '$D(^XTMP("APCLDP1",APCLJOB,APCLBTH)) D HEAD W !!,"NO PATIENTS TO REPORT" G DONE

 S APCLPROV=0 F  S APCLPROV=$O(^XTMP("APCLDP1",APCLJOB,APCLBTH,APCLPROV)) Q:APCLPROV'=+APCLPROV!($D(APCLQ))  D

 .S DFN="" K APCLQ

 .S APCLSUB=0

 .D HEAD Q:$D(APCLQ)  F  S DFN=$O(^XTMP("APCLDP1",APCLJOB,APCLBTH,APCLPROV,DFN)) Q:DFN=""!($D(APCLQ))  D DFN

 .Q:$D(APCLQ)

 .I $Y>(IOSL-3) D HEAD Q:$D(APCLQ)

 .W !,"Total # of Patients for "_$$VAL^XBDIQ1(200,APCLPROV,.01),":  ",APCLSUB,!

 G:$D(APCLQ) DONE

DONE D DONE^APCLOSUT

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

 Q

DFN ;

 S APCLSUB=APCLSUB+1

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

 W !,$E($P(^DPT(DFN,0),U),1,15)

 S APCLHRCN=$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^(0),U,2),1:"<none>")

 W ?17,$J(APCLHRCN,7)

 K ^UTILITY("DIQ1",$J) S DIC=9000001,DA=DFN,DR=1102.99 D EN^DIQ1

 S APCLAGE=$G(^UTILITY("DIQ1",$J,9000001,DFN,1102.99)) K ^UTILITY("DIQ1",$J)

 W ?26,APCLAGE

VSTS ; process visits

 S APCLRCNT=0

 K APCLRLOC,APCLPRV,APCLPROB

 S APCLR=0,APCLBDO=9999999-APCLBD,APCLEDO=9999999-APCLED,APCLSD=APCLED-1,APCLRCNT=0

 F  S APCLSD=$O(^AUPNVSIT("AA",DFN,APCLSD)) Q:APCLSD>APCLBDO!(APCLSD="")  D

 .S APCLR=0 F  S APCLR=$O(^AUPNVSIT("AA",DFN,APCLSD,APCLR)) Q:APCLR'=+APCLR  D

 ..;TABLE PROVIDERS

 ..S APCLP=0 F  S APCLP=$O(^AUPNVPRV("AD",APCLR,APCLP)) Q:APCLP'=+APCLP  S P=$P(^AUPNVPRV(APCLP,0),U) D

 ...I P=APCLPROV S APCLRCNT=APCLRCNT+1 Q

 ...S:'$D(APCLPRV($S($P(^DD(9000010.06,.01,0),U,2)[200:$P(^VA(200,P,0),U),1:$P(^DIC(16,P,0),U)))) APCLPRV($S($P(^DD(9000010.06,.01,0),U,2)[200:$P(^VA(200,P,0),U),1:$P(^DIC(16,P,0),U)))=0

 ...S APCLPRV($S($P(^DD(9000010.06,.01,0),U,2)[200:$P(^VA(200,P,0),U),1:$P(^DIC(16,P,0),U)))=APCLPRV($S($P(^DD(9000010.06,.01,0),U,2)[200:$P(^VA(200,P,0),U),1:$P(^DIC(16,P,0),U)))+1

 ..;TABLE PROBLEMS

 ..;S APCLP=0 F  S APCLP=$O(^AUPNVPOV("AD",APCLR,APCLP)) Q:APCLP'=+APCLP  S P=$P(^AUPNVPOV(APCLP,0),U),APCLPROB($P(^ICD9(P,0),U)_" - "_$E($P(^ICD9(P,0),U,3),1,25))=""  ;cmi/anch/maw 9/10/2007 orig line

 ..S APCLP=0 F  S APCLP=$O(^AUPNVPOV("AD",APCLR,APCLP)) Q:APCLP'=+APCLP  S P=$P(^AUPNVPOV(APCLP,0),U),APCLPROB($P($$ICDDX^ICDEX(P),U,2)_" - "_$E($P($$ICDDX^ICDEX(P),U,4),1,25))=""  ;cmi/anch/maw 9/10/2007 csv

 ..Q

 .Q

 K APCLLINE,APCLPRNT,APCLPCNT,APCLPRNM

 S APCLLINE(1)=""

 K APCLPRNM S X="",C=0,K=15 F  S X=$O(APCLPRV(X)) Q:X=""  S C=C+1,APCLPRNM(C)=$E(X,1,10)_" ("_APCLPRV(X)_")"

 D LINE

 K APCLPRNM S X="",C=0,K=25 F  S X=$O(APCLPROB(X)) Q:X=""  S C=C+1,APCLPRNM(C)=X

 D LINE

 S APCLRCNT=$J(APCLRCNT,4) W ?31,APCLRCNT S X=0 F  S X=$O(APCLLINE(X)) Q:X'=+X  W ?38,APCLLINE(X),!

 Q

LINE ;

 I '$D(APCLPRNM) S APCLPRNT="--" D

 .S APCLPRNT=$E(APCLPRNT,1,K) D

 ..S J=$L(APCLPRNT),APCLLINE(1)=APCLLINE(1)_APCLPRNT F I=J:1:K S APCLLINE(1)=APCLLINE(1)_" "

 S X=0 F  S X=$O(APCLPRNM(X)) Q:X'=+X  D

 .I X=1 D  Q

 ..S APCLPRNT=$E(APCLPRNM(1),1,K) D

 ...S J=$L(APCLPRNT),APCLLINE(1)=APCLLINE(1)_APCLPRNT F I=J:1:K S APCLLINE(1)=APCLLINE(1)_" "

 .S APCLPRNT=$E(APCLPRNM(X),1,K) D

 ..I '$D(APCLLINE(X)) S APCLLINE(X)="",$P(APCLLINE(X)," ",($L(APCLLINE(1))-K))=""

 ..S J=$L(APCLPRNT),APCLLINE(X)=APCLLINE(X)_APCLPRNT F I=J:1:K S APCLLINE(X)=APCLLINE(X)_" "

 S X=1 F  S X=$O(APCLLINE(X)) Q:X'=+X  I $L(APCLLINE(X))<$L(APCLLINE(1)) S K=$L(APCLLINE(X))+1,J=$L(APCLLINE(1)) F I=K:1:J S APCLLINE(X)=APCLLINE(X)_" "

 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 APCLQ="" Q

HEAD1 ;

 W:$D(IOF) @IOF S APCLPG=APCLPG+1

 W $P(^VA(200,DUZ,0),U,2),?72,"Page ",APCLPG,!

 W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!

 W ?5,"PATIENTS BY DESIGNATED PRIMARY CARE PROVIDER, WITH VISIT COUNTS",!

 I $G(APCLPROV) S P=$S($P(^DD(9000010.06,.01,0),U,2)[200:$P(^VA(200,APCLPROV,0),U),1:$P(^DIC(16,APCLPROV,0),U)),L=$L(P) W ?(80-(L+35)/2),"DESIGNATED PRIMARY CARE PROVIDER:  ",P,!

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

PIH ;

 W !!?31,"TIMES",?38,"OTHER"

 W !?31,"SEEN",?38,"PROVIDERS",!

 W "PATIENT NAME",?17,"CHART #",?26,"AGE",?31,"BY DP",?38,"SEEN",?54,"ICD DIAGNOSES",!,APCL80D

 Q

APCLDP1P  ; IHS/CMI/LAB - print active client list ;

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

 +2       ;

 +3       ;cmi/anch/maw 9/10/2007 code set versioning in VSTS

 +4       ;

PRINT     ;

START     ;

 +1        SET APCL80D="-------------------------------------------------------------------------------"

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

               DO HEAD

               WRITE !!,"NO PATIENTS TO REPORT"

               GOTO DONE

 +5        SET APCLPROV=0

           FOR 

               SET APCLPROV=$ORDER(^XTMP("APCLDP1",APCLJOB,APCLBTH,APCLPROV))

               IF APCLPROV'=+APCLPROV!($DATA(APCLQ))

                   QUIT 

               Begin DoDot:1

 +6                SET DFN=""

                   KILL APCLQ

 +7                SET APCLSUB=0

 +8                DO HEAD

                   IF $DATA(APCLQ)

                       QUIT 

                   FOR 

                       SET DFN=$ORDER(^XTMP("APCLDP1",APCLJOB,APCLBTH,APCLPROV,DFN))

                       IF DFN=""!($DATA(APCLQ))

                           QUIT 

                       DO DFN

 +9                IF $DATA(APCLQ)

                       QUIT 

 +10               IF $Y>(IOSL-3)

                       DO HEAD

                       IF $DATA(APCLQ)

                           QUIT 

 +11               WRITE !,"Total # of Patients for "_$$VAL^XBDIQ1(200,APCLPROV,.01),":  ",APCLSUB,!

               End DoDot:1

 +12       IF $DATA(APCLQ)

               GOTO DONE

DONE       DO DONE^APCLOSUT

 +1        KILL ^XTMP("APCLDP1",APCLJOB,APCLBTH),APCLJOB,APCLBTH

 +2        QUIT 

DFN       ;

 +1        SET APCLSUB=APCLSUB+1

 +2        IF $Y>(IOSL-6)

               DO HEAD

               IF $DATA(APCLQ)

                   QUIT 

 +3        WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,15)

 +4        SET APCLHRCN=$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE(^(0),U,2),1:"<none>")

 +5        WRITE ?17,$JUSTIFY(APCLHRCN,7)

 +6        KILL ^UTILITY("DIQ1",$JOB)

           SET DIC=9000001

           SET DA=DFN

           SET DR=1102.99

           DO EN^DIQ1

 +7        SET APCLAGE=$GET(^UTILITY("DIQ1",$JOB,9000001,DFN,1102.99))

           KILL ^UTILITY("DIQ1",$JOB)

 +8        WRITE ?26,APCLAGE

VSTS      ; process visits

 +1        SET APCLRCNT=0

 +2        KILL APCLRLOC,APCLPRV,APCLPROB

 +3        SET APCLR=0

           SET APCLBDO=9999999-APCLBD

           SET APCLEDO=9999999-APCLED

           SET APCLSD=APCLED-1

           SET APCLRCNT=0

 +4        FOR 

               SET APCLSD=$ORDER(^AUPNVSIT("AA",DFN,APCLSD))

               IF APCLSD>APCLBDO!(APCLSD="")

                   QUIT 

               Begin DoDot:1

 +5                SET APCLR=0

                   FOR 

                       SET APCLR=$ORDER(^AUPNVSIT("AA",DFN,APCLSD,APCLR))

                       IF APCLR'=+APCLR

                           QUIT 

                       Begin DoDot:2

 +6       ;TABLE PROVIDERS

 +7                        SET APCLP=0

                           FOR 

                               SET APCLP=$ORDER(^AUPNVPRV("AD",APCLR,APCLP))

                               IF APCLP'=+APCLP

                                   QUIT 

                               SET P=$PIECE(^AUPNVPRV(APCLP,0),U)

                               Begin DoDot:3

 +8                                IF P=APCLPROV

                                       SET APCLRCNT=APCLRCNT+1

                                       QUIT 

 +9                                IF '$DATA(APCLPRV($SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200

                                       SET APCLPRV($SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$PIECE(^VA(200,P,0),U),1:$PIECE(^DIC(16,P,0),U)))=0

 +10                               SET APCLPRV($SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$PIECE(^VA(200,P,0),U),1:$PIECE(^DIC(16,P,0),U)))=APCLPRV($SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$PIECE(^VA(200,P,0),U),1:$PIECE(^DIC(16,P,0),U)))+1

                               End DoDot:3

 +11      ;TABLE PROBLEMS

 +12      ;S APCLP=0 F  S APCLP=$O(^AUPNVPOV("AD",APCLR,APCLP)) Q:APCLP'=+APCLP  S P=$P(^AUPNVPOV(APCLP,0),U),APCLPROB($P(^ICD9(P,0),U)_" - "_$E($P(^ICD9(P,0),U,3),1,25))=""  ;cmi/anch/maw 9/10/2007 orig line

 +13      ;cmi/anch/maw 9/10/2007 csv

                           SET APCLP=0

                           FOR 

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

                               IF APCLP'=+APCLP

                                   QUIT 

                               SET P=$PIECE(^AUPNVPOV(APCLP,0),U)

                               SET APCLPROB($PIECE($$ICDDX^ICDEX(P),U,2)_" - "_$EXTRACT($PIECE($$ICDDX^ICDEX(P),U,4),1,25))=""

 +14                       QUIT 

                       End DoDot:2

 +15               QUIT 

               End DoDot:1

 +16       KILL APCLLINE,APCLPRNT,APCLPCNT,APCLPRNM

 +17       SET APCLLINE(1)=""

 +18       KILL APCLPRNM

           SET X=""

           SET C=0

           SET K=15

           FOR 

               SET X=$ORDER(APCLPRV(X))

               IF X=""

                   QUIT 

               SET C=C+1

               SET APCLPRNM(C)=$EXTRACT(X,1,10)_" ("_APCLPRV(X)_")"

 +19       DO LINE

 +20       KILL APCLPRNM

           SET X=""

           SET C=0

           SET K=25

           FOR 

               SET X=$ORDER(APCLPROB(X))

               IF X=""

                   QUIT 

               SET C=C+1

               SET APCLPRNM(C)=X

 +21       DO LINE

 +22       SET APCLRCNT=$JUSTIFY(APCLRCNT,4)

           WRITE ?31,APCLRCNT

           SET X=0

           FOR 

               SET X=$ORDER(APCLLINE(X))

               IF X'=+X

                   QUIT 

               WRITE ?38,APCLLINE(X),!

 +23       QUIT 

LINE      ;

 +1        IF '$DATA(APCLPRNM)

               SET APCLPRNT="--"

               Begin DoDot:1

 +2                SET APCLPRNT=$EXTRACT(APCLPRNT,1,K)

                   Begin DoDot:2

 +3                    SET J=$LENGTH(APCLPRNT)

                       SET APCLLINE(1)=APCLLINE(1)_APCLPRNT

                       FOR I=J:1:K

                           SET APCLLINE(1)=APCLLINE(1)_" "

                   End DoDot:2

               End DoDot:1

 +4        SET X=0

           FOR 

               SET X=$ORDER(APCLPRNM(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +5                IF X=1

                       Begin DoDot:2

 +6                        SET APCLPRNT=$EXTRACT(APCLPRNM(1),1,K)

                           Begin DoDot:3

 +7                            SET J=$LENGTH(APCLPRNT)

                               SET APCLLINE(1)=APCLLINE(1)_APCLPRNT

                               FOR I=J:1:K

                                   SET APCLLINE(1)=APCLLINE(1)_" "

                           End DoDot:3

                       End DoDot:2

                       QUIT 

 +8                SET APCLPRNT=$EXTRACT(APCLPRNM(X),1,K)

                   Begin DoDot:2

 +9                    IF '$DATA(APCLLINE(X))

                           SET APCLLINE(X)=""

                           SET $PIECE(APCLLINE(X)," ",($LENGTH(APCLLINE(1))-K))=""

 +10                   SET J=$LENGTH(APCLPRNT)

                       SET APCLLINE(X)=APCLLINE(X)_APCLPRNT

                       FOR I=J:1:K

                           SET APCLLINE(X)=APCLLINE(X)_" "

                   End DoDot:2

               End DoDot:1

 +11       SET X=1

           FOR 

               SET X=$ORDER(APCLLINE(X))

               IF X'=+X

                   QUIT 

               IF $LENGTH(APCLLINE(X))<$LENGTH(APCLLINE(1))

                   SET K=$LENGTH(APCLLINE(X))+1

                   SET J=$LENGTH(APCLLINE(1))

                   FOR I=K:1:J

                       SET APCLLINE(X)=APCLLINE(X)_" "

 +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 APCLQ=""

                       QUIT 

HEAD1     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

           SET APCLPG=APCLPG+1

 +2        WRITE $PIECE(^VA(200,DUZ,0),U,2),?72,"Page ",APCLPG,!

 +3        WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!

 +4        WRITE ?5,"PATIENTS BY DESIGNATED PRIMARY CARE PROVIDER, WITH VISIT COUNTS",!

 +5        IF $GET(APCLPROV)

               SET P=$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$PIECE(^VA(200,APCLPROV,0),U),1:$PIECE(^DIC(16,APCLPROV,0),U))

               SET L=$LENGTH(P)

               WRITE ?(80-(L+35)/2),"DESIGNATED PRIMARY CARE PROVIDER:  ",P,!

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

PIH       ;

 +1        WRITE !!?31,"TIMES",?38,"OTHER"

 +2        WRITE !?31,"SEEN",?38,"PROVIDERS",!

 +3        WRITE "PATIENT NAME",?17,"CHART #",?26,"AGE",?31,"BY DP",?38,"SEEN",?54,"ICD DIAGNOSES",!,APCL80D

 +4        QUIT