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
