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
