APCLGVP.m

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

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

 ;

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

 ;

PRINT ;

 I APCLOUT="S" D  D DONE Q

 .S X=0 F  S X=$O(^XTMP("APCLGV",APCLJOB,APCLBTH,"PATIENTS","TEMPLATE",X)) Q:X'=+X  S ^DIBT(APCLSTMP,1,X)=""

 .W !,"Search template: ",$P(^DIBT(APCLSTMP,0),U)," has been created."

START ;

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

 K APCLQ

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

 S APCLPG=0

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

SRTV ;

 D HEAD

 S APCLSRT="" F  S APCLSRT=$O(^XTMP("APCLGV",APCLJOB,APCLBTH,"PATIENTS",APCLSRT)) Q:APCLSRT=""!($D(APCLQ))  D PAT

 G DONE

PAT ;

 I 'APCLNPAG D  Q:$D(APCLQ)

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

 .W !!,APCLSORV,":  ",APCLSRT,!

 I APCLNPAG D HEAD Q:$D(APCLQ)  W !,APCLSORV,":  ",APCLSRT,!

 S DFN="" F  S DFN=$O(^XTMP("APCLGV",APCLJOB,APCLBTH,"PATIENTS",APCLSRT,DFN)) Q:DFN=""!($D(APCLQ))  D DFN

 Q

DONE D DONE^APCLOSUT

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

 Q

DFN ;

 I $Y>(IOSL-4) 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)

 ;begin Y2K

 ;W ?27,$P(^DPT(DFN,0),U,2) S Y=$P(^DPT(DFN,0),U,3) W ?31,$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3) ;Y2000

 W ?27,$P(^DPT(DFN,0),U,2) S Y=$P(^DPT(DFN,0),U,3) W ?30,$E(Y,4,5),"/",$E(Y,6,7),"/",(1700+($E(Y,1,3))) ;Y2000

 ;end Y2K

VSTS ; process visits

 K APCLRLOC,APCLPRV,APCLPROB

 S APCLVIEN=0,APCLBDO=(9999999-APCLBD)_".9999",APCLEDO=9999999-APCLED,APCLSD=(APCLEDO-1)_".9999",APCLRCNT=0

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

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

 ..Q:'$P(^AUPNVSIT(APCLVIEN,0),U,9)

 ..Q:$P(^AUPNVSIT(APCLVIEN,0),U,11)

 ..S APCLVREC=^AUPNVSIT(APCLVIEN,0)

 ..D SCREENS^APCLGV

 ..Q:$D(APCLSKIP)

 ..S APCLRCNT=APCLRCNT+1 ;COUNT # VISITS

 ..;TABLE LOC SEEN

 ..I $P(^AUPNVSIT(APCLVIEN,0),U,6)]"",'$D(APCLRLOC($P(^DIC(4,$P(^(0),U,6),0),U))) S APCLRLOC($P(^DIC(4,$P(^AUPNVSIT(APCLVIEN,0),U,6),0),U))=""

 ..;TABLE PROVIDERS

 ..S APCLP=0 F  S APCLP=$O(^AUPNVPRV("AD",APCLVIEN,APCLP)) Q:APCLP'=+APCLP  S P=$P(^AUPNVPRV(APCLP,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)))=""

 ..;TABLE PROBLEMS

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

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

 ..Q

 .Q

 K APCLLINE,APCLPRNT,APCLPCNT,APCLPRNM

 S APCLLINE(1)=""

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

 D LINE

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

 D LINE

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

 D LINE

 S APCLRCNT=$J(APCLRCNT,4),APCLLINE(1)=APCLLINE(1)_APCLRCNT,X=0 F  S X=$O(APCLLINE(X)) Q:X'=+X!($D(APCLQ))  D

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

 .W ?41,APCLLINE(X),!

 Q

LINE ;

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

 .S APCLPRNT=$E(APCLPRNT,1,10) 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,10) 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,10) 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 NEW X

 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 ?25,"PATIENTS SEEN AT LEAST ",APCLNUM," TIMES",!

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

PIH W !!,?41,"LOCATION",?53,"PROVIDER",?65,"DX",?75,"#",!

 W "PATIENT NAME",?17,"CHART #",?26,"SEX",?31,"DOB",?41,"SEEN",?53,"SEEN",?65,"CODES",?73,"VISITS",!,APCL80D,!

 Q

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

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

 +2       ;

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

 +4       ;

PRINT     ;

 +1        IF APCLOUT="S"

               Begin DoDot:1

 +2                SET X=0

                   FOR 

                       SET X=$ORDER(^XTMP("APCLGV",APCLJOB,APCLBTH,"PATIENTS","TEMPLATE",X))

                       IF X'=+X

                           QUIT 

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

 +3                WRITE !,"Search template: ",$PIECE(^DIBT(APCLSTMP,0),U)," has been created."

               End DoDot:1

               DO DONE

               QUIT 

START     ;

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

 +2        KILL APCLQ

 +3        SET Y=APCLBD

           DO DD^%DT

           SET APCLBDD=Y

           SET Y=APCLED

           DO DD^%DT

           SET APCLEDD=Y

 +4        SET APCLPG=0

 +5        IF '$DATA(^XTMP("APCLGV",APCLJOB,APCLBTH))

               DO HEAD

               WRITE !!,"NO PATIENTS TO REPORT"

               GOTO DONE

SRTV      ;

 +1        DO HEAD

 +2        SET APCLSRT=""

           FOR 

               SET APCLSRT=$ORDER(^XTMP("APCLGV",APCLJOB,APCLBTH,"PATIENTS",APCLSRT))

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

                   QUIT 

               DO PAT

 +3        GOTO DONE

PAT       ;

 +1        IF 'APCLNPAG

               Begin DoDot:1

 +2                IF $Y>(IOSL-5)

                       DO HEAD

                       IF $DATA(APCLQ)

                           QUIT 

 +3                WRITE !!,APCLSORV,":  ",APCLSRT,!

               End DoDot:1

               IF $DATA(APCLQ)

                   QUIT 

 +4        IF APCLNPAG

               DO HEAD

               IF $DATA(APCLQ)

                   QUIT 

               WRITE !,APCLSORV,":  ",APCLSRT,!

 +5        SET DFN=""

           FOR 

               SET DFN=$ORDER(^XTMP("APCLGV",APCLJOB,APCLBTH,"PATIENTS",APCLSRT,DFN))

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

                   QUIT 

               DO DFN

 +6        QUIT 

DONE       DO DONE^APCLOSUT

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

 +2        QUIT 

DFN       ;

 +1        IF $Y>(IOSL-4)

               DO HEAD

               IF $DATA(APCLQ)

                   QUIT 

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

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

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

 +5       ;begin Y2K

 +6       ;W ?27,$P(^DPT(DFN,0),U,2) S Y=$P(^DPT(DFN,0),U,3) W ?31,$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3) ;Y2000

 +7       ;Y2000

           WRITE ?27,$PIECE(^DPT(DFN,0),U,2)

           SET Y=$PIECE(^DPT(DFN,0),U,3)

           WRITE ?30,$EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",(1700+($EXTRACT(Y,1,3)))

 +8       ;end Y2K

VSTS      ; process visits

 +1        KILL APCLRLOC,APCLPRV,APCLPROB

 +2        SET APCLVIEN=0

           SET APCLBDO=(9999999-APCLBD)_".9999"

           SET APCLEDO=9999999-APCLED

           SET APCLSD=(APCLEDO-1)_".9999"

           SET APCLRCNT=0

 +3        FOR 

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

               IF APCLSD>APCLBDO!(APCLSD="")

                   QUIT 

               Begin DoDot:1

 +4                SET APCLVIEN=0

                   FOR 

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

                       IF APCLVIEN'=+APCLVIEN

                           QUIT 

                       Begin DoDot:2

 +5                        IF '$PIECE(^AUPNVSIT(APCLVIEN,0),U,9)

                               QUIT 

 +6                        IF $PIECE(^AUPNVSIT(APCLVIEN,0),U,11)

                               QUIT 

 +7                        SET APCLVREC=^AUPNVSIT(APCLVIEN,0)

 +8                        DO SCREENS^APCLGV

 +9                        IF $DATA(APCLSKIP)

                               QUIT 

 +10      ;COUNT # VISITS

                           SET APCLRCNT=APCLRCNT+1

 +11      ;TABLE LOC SEEN

 +12                       IF $PIECE(^AUPNVSIT(APCLVIEN,0),U,6)]""

                               IF '$DATA(APCLRLOC($PIECE(^DIC(4,$PIECE(^(0),U,6),0),U)))

                                   SET APCLRLOC($PIECE(^DIC(4,$PIECE(^AUPNVSIT(APCLVIEN,0),U,6),0),U))=""

 +13      ;TABLE PROVIDERS

 +14                       SET APCLP=0

                           FOR 

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

                               IF APCLP'=+APCLP

                                   QUIT 

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

                               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)))=""

 +15      ;TABLE PROBLEMS

 +16      ;S APCLP=0 F  S APCLP=$O(^AUPNVPOV("AD",APCLVIEN,APCLP)) Q:APCLP'=+APCLP  S P=$P(^AUPNVPOV(APCLP,0),U),APCLPROB($P(^ICD9(P,0),U))=""  ;cmi/anch/maw 9/10/2007 orig line

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

                           SET APCLP=0

                           FOR 

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

                               IF APCLP'=+APCLP

                                   QUIT 

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

                               SET APCLPROB($PIECE($$ICDDX^ICDEX(P),U,2))=""

 +18                       QUIT 

                       End DoDot:2

 +19               QUIT 

               End DoDot:1

 +20       KILL APCLLINE,APCLPRNT,APCLPCNT,APCLPRNM

 +21       SET APCLLINE(1)=""

 +22       SET X=""

           SET C=0

           SET K=11

           FOR 

               SET X=$ORDER(APCLRLOC(X))

               IF X=""

                   QUIT 

               SET C=C+1

               SET APCLPRNM(C)=X

 +23       DO LINE

 +24       KILL APCLPRNM

           SET X=""

           SET C=0

           SET K=11

           FOR 

               SET X=$ORDER(APCLPRV(X))

               IF X=""

                   QUIT 

               SET C=C+1

               SET APCLPRNM(C)=X

 +25       DO LINE

 +26       KILL APCLPRNM

           SET X=""

           SET C=0

           SET K=9

           FOR 

               SET X=$ORDER(APCLPROB(X))

               IF X=""

                   QUIT 

               SET C=C+1

               SET APCLPRNM(C)=X

 +27       DO LINE

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

           SET APCLLINE(1)=APCLLINE(1)_APCLRCNT

           SET X=0

           FOR 

               SET X=$ORDER(APCLLINE(X))

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

                   QUIT 

               Begin DoDot:1

 +29               IF $Y>(IOSL-5)

                       DO HEAD

                       IF $DATA(APCLQ)

                           QUIT 

 +30               WRITE ?41,APCLLINE(X),!

               End DoDot:1

 +31       QUIT 

LINE      ;

 +1        IF '$DATA(APCLPRNM)

               SET APCLPRNT="--"

               Begin DoDot:1

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

                   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,10)

                           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,10)

                   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       NEW X

 +1        IF 'APCLPG

               GOTO HEAD1

 +2        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 ?25,"PATIENTS SEEN AT LEAST ",APCLNUM," TIMES",!

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

PIH        WRITE !!,?41,"LOCATION",?53,"PROVIDER",?65,"DX",?75,"#",!

 +1        WRITE "PATIENT NAME",?17,"CHART #",?26,"SEX",?31,"DOB",?41,"SEEN",?53,"SEEN",?65,"CODES",?73,"VISITS",!,APCL80D,!

 +2        QUIT