APCLADAP ; IHS/CMI/LAB - PRINT CLINIC VISITS ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
INIT ;initialize variables
S APCLSTOP="",APCLPAGE=0
I '$D(^XTMP("APCLADA",APCLJOB,APCLBT)) D HEAD W !,"No visits to report." G END
S (APCLPGRD,APCLVGRA)=0
SET ;
S APCLCLX=0
F S APCLCLX=$O(^XTMP("APCLADA",APCLJOB,APCLBT,APCLCLX)) Q:APCLCLX=""!(APCLSTOP="^") D SET2
G:APCLSTOP="^" END
D FINAL
END ;
D DONE^APCLOSUT
K ^XTMP("APCLADA",APCLJOB,APCLBT)
Q
SET2 ;
S (APCLNAME,APCLPTOT,APCLVTOT)=0 D HEAD
F S APCLNAME=$O(^XTMP("APCLADA",APCLJOB,APCLBT,APCLCLX,APCLNAME)) Q:APCLNAME=""!(APCLSTOP="^") S APCLDFN=0 D SET3
Q:APCLSTOP=U
D TOTALS
Q
SET3 F S APCLDFN=$O(^XTMP("APCLADA",APCLJOB,APCLBT,APCLCLX,APCLNAME,APCLDFN)) Q:APCLDFN=""!(APCLSTOP="^") D SET4
Q
SET4 ;
S (APCLVDT,APCLFVS)=0 ;visit date & first visit flag for line feed
;set and print demographic data
S APCLPTOT=APCLPTOT+1 ;increment patient count for clinic
I $G(APCLLOC)]"",$D(^AUPNPAT(APCLDFN,41,APCLLOC,0)) S APCLHRCN=$P(^AUPNPAT(APCLDFN,41,APCLLOC,0),U,2) G SET41
S APCLHRCN=$P($G(^AUPNPAT(APCLDFN,41,DUZ(2),0)),U,2)
SET41 K ^UTILITY("DIQ1",$J) S DIC=9000001,DA=APCLDFN,DR=1102.99 D EN^DIQ1
S APCLAGE=$G(^UTILITY("DIQ1",$J,9000001,APCLDFN,1102.99)) K ^UTILITY("DIQ1",$J)
I $Y>(IOSL-5) D PAGE Q:APCLSTOP="^"
W !,$E(APCLNAME,1,13),?15,$J(APCLHRCN,6),?23,$J(APCLAGE,2)
;
;find visit
F S APCLVDT=$O(^XTMP("APCLADA",APCLJOB,APCLBT,APCLCLX,APCLNAME,APCLDFN,APCLVDT)) Q:APCLVDT="" S APCLVDFN=0 D SET5
Q
SET5 ;
F S APCLVDFN=$O(^XTMP("APCLADA",APCLJOB,APCLBT,APCLCLX,APCLNAME,APCLDFN,APCLVDT,APCLVDFN)) Q:APCLVDFN=""!(APCLSTOP="^") D PRNT
Q
PRNT ;
S APCLVTOT=APCLVTOT+1 ;increment visit count
I APCLFVS W ! I $Y>(IOSL-5) D PAGE Q:APCLSTOP="^"
S APCLPOVC=0,APCLFVS=1,APCLFPV=0
W ?26,$E(APCLVDT,4,5),"/",$E(APCLVDT,6,7),"/",$E(APCLVDT,2,3)_" "_$E($P(APCLVDT,".",2)_"0000",1,4)
;
;set and print provider class code
S APCLPRV=0
PRV S APCLPRV=$O(^AUPNVPRV("AD",APCLVDFN,APCLPRV))
I APCLPRV="" S APCLPV=0,APCLPOVC=0 K APCLNARR G POV
G PRV:'$D(^AUPNVPRV(APCLPRV,0)),PRV:$P(^(0),"^",4)'="P"
S X=+^AUPNVPRV(APCLPRV,0)
I $P(^DD(9000010.06,.01,0),U,2)[6 S X=$P(^DIC(6,X,0),"^",4),APCLCLS=$S(X="":"",'$D(^DIC(7,X,9999999)):"",1:$P(^DIC(7,X,9999999),"^"))
I $P(^DD(9000010.06,.01,0),U,2)[200 S APCLCLS=$$PROVCLSC^XBFUNC1(X)
W ?41,APCLCLS
;
;
S APCLPV=0,APCLPOVC=0 K APCLNARR
POV S APCLPV=$O(^AUPNVPOV("AD",APCLVDFN,APCLPV))
I APCLPV="" S APCLVDEN=0,APCLPOVC=1 G ADA
G POV:'$D(^AUPNVPOV(APCLPV,0)) S APCLSTR=^(0)
S APCLNAR=$$VAL^XBDIQ1(9000010.07,APCLPV,.04)
;S APCLNAR=$S(APCLNAR="":"",$D(^AUTNPOV(APCLNAR,0)):$P(^(0),"^"),1:"")
S APCLPOVC=APCLPOVC+1
S APCLNARR(APCLPOVC)=$E(APCLNAR,1,26)
G POV
;
;set and print procedures
ADA S APCLVDEN=$O(^AUPNVDEN("AD",APCLVDFN,APCLVDEN))
Q:APCLVDEN=""
G ADA:'$D(^AUPNVDEN(APCLVDEN,0)) S APCLSTR=^(0)
S APCLADA=+APCLSTR
S APCLADA=$S(APCLADA="":"",1:$P(^AUTTADA(APCLADA,0),"^"))
I APCLFPV W ! I $Y>(IOSL-5) D PAGE Q:APCLSTOP="^" W !
I 'APCLFPV S APCLFPV=1
W ?45,APCLADA,?53,$S($D(APCLNARR(APCLPOVC)):APCLNARR(APCLPOVC),1:"") S APCLPOVC=APCLPOVC+1
G ADA
;
FINAL ;print grand totals
G END:APCLCL'="A"
D HEAD
W !!?39,"TOTAL PATIENTS: ",APCLPGRD
W !!?41,"TOTAL VISITS: ",APCLVGRA
Q
;
TOTALS ;print totals
I $Y>(IOSL-5) D PAGE
W !!?28,"TOTAL PATIENTS FOR CLINIC: ",APCLPTOT
W !!?30,"TOTAL VISITS FOR CLINIC: ",APCLVTOT
S APCLPGRD=APCLPGRD+APCLPTOT,APCLVGRA=APCLVGRA+APCLVTOT
Q:IOST'?1"C-".E
;R !!,"Enter <return> to continue or '^' to stop",APCLSTOP:DTIME
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I $D(DIRUT) S APCLSTOP="^" Q
Q
;
HEAD ;
W:$D(IOF) @IOF,!?11,"*****Confidential Patient Data Covered by Privacy Act*****",!
S X=$P(^DIC(4,DUZ(2),0),"^"),APCLPAGE=APCLPAGE+1
W !!,$P(^VA(200,DUZ,0),"^",2),?(80-$L(X)/2),X,?72,"Page ",APCLPAGE
S X=$P($H,",",2) D TIME W !,Y
I $G(APCLCLX)="" S X="No Clinic data to report" G HD1
I APCLCLX="E" S X="VISITS WITH NO ASSIGNED CLINIC CODE" G HD1
I APCLCLX]"" S X="CLINIC VISITS FOR "_$P(^DIC(40.7,APCLCLX,0),"^")_" ("_$P(^(0),"^",2)_")" W ?(80-$L(X)/2),X
HD1 S Y=DT X ^DD("DD") W !,Y
;begin Y2K
;W ?28,"for ",$E(APCLBD,4,5),"/",$E(APCLBD,6,7),"/",$E(APCLBD,2,3) ;Y2000
;W " to ",$E(APCLED,4,5),"/",$E(APCLED,6,7),"/",$E(APCLED,2,3) ;Y2000
W ?23,"for ",$$FMTE^XLFDT(APCLBD)," to ",$$FMTE^XLFDT(APCLED) ;Y2000
;end Y2K
W !!,"NAME",?16,"HRCN",?22,"AGE",?27,"VISIT DATE",?41,"PRV",?46,"ADA",?53,"PROV NARRATIVE",!
Q
;
PAGE ;form feed to new page
I IOST'?1"C-".E D HEAD Q
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="E" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLSTOP="^" Q
I APCLSTOP'="^" D HEAD
Q
TIME S Y="" Q:'$D(X) Q:X<0!(X>86400)
S %A=X\60,%B=%A\60 S:%B>12 %B=%B-12 S:%B=0 %B=12 S:%B<10 %B=" "_%B
S %C=$S(%A=0:"M ",%A=720:"N ",%A=1440:"M ",%A<720:"am",1:"pm")
S Y=%B_":"_$E(%A#60+100,2,3)_" "_%C K %A,%B,%C Q
APCLADAP ; IHS/CMI/LAB - PRINT CLINIC VISITS ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
INIT ;initialize variables
+1 SET APCLSTOP=""
SET APCLPAGE=0
+2 IF '$DATA(^XTMP("APCLADA",APCLJOB,APCLBT))
DO HEAD
WRITE !,"No visits to report."
GOTO END
+3 SET (APCLPGRD,APCLVGRA)=0
SET ;
+1 SET APCLCLX=0
+2 FOR
SET APCLCLX=$ORDER(^XTMP("APCLADA",APCLJOB,APCLBT,APCLCLX))
IF APCLCLX=""!(APCLSTOP="^")
QUIT
DO SET2
+3 IF APCLSTOP="^"
GOTO END
+4 DO FINAL
END ;
+1 DO DONE^APCLOSUT
+2 KILL ^XTMP("APCLADA",APCLJOB,APCLBT)
+3 QUIT
SET2 ;
+1 SET (APCLNAME,APCLPTOT,APCLVTOT)=0
DO HEAD
+2 FOR
SET APCLNAME=$ORDER(^XTMP("APCLADA",APCLJOB,APCLBT,APCLCLX,APCLNAME))
IF APCLNAME=""!(APCLSTOP="^")
QUIT
SET APCLDFN=0
DO SET3
+3 IF APCLSTOP=U
QUIT
+4 DO TOTALS
+5 QUIT
SET3 FOR
SET APCLDFN=$ORDER(^XTMP("APCLADA",APCLJOB,APCLBT,APCLCLX,APCLNAME,APCLDFN))
IF APCLDFN=""!(APCLSTOP="^")
QUIT
DO SET4
+1 QUIT
SET4 ;
+1 ;visit date & first visit flag for line feed
SET (APCLVDT,APCLFVS)=0
+2 ;set and print demographic data
+3 ;increment patient count for clinic
SET APCLPTOT=APCLPTOT+1
+4 IF $GET(APCLLOC)]""
IF $DATA(^AUPNPAT(APCLDFN,41,APCLLOC,0))
SET APCLHRCN=$PIECE(^AUPNPAT(APCLDFN,41,APCLLOC,0),U,2)
GOTO SET41
+5 SET APCLHRCN=$PIECE($GET(^AUPNPAT(APCLDFN,41,DUZ(2),0)),U,2)
SET41 KILL ^UTILITY("DIQ1",$JOB)
SET DIC=9000001
SET DA=APCLDFN
SET DR=1102.99
DO EN^DIQ1
+1 SET APCLAGE=$GET(^UTILITY("DIQ1",$JOB,9000001,APCLDFN,1102.99))
KILL ^UTILITY("DIQ1",$JOB)
+2 IF $Y>(IOSL-5)
DO PAGE
IF APCLSTOP="^"
QUIT
+3 WRITE !,$EXTRACT(APCLNAME,1,13),?15,$JUSTIFY(APCLHRCN,6),?23,$JUSTIFY(APCLAGE,2)
+4 ;
+5 ;find visit
+6 FOR
SET APCLVDT=$ORDER(^XTMP("APCLADA",APCLJOB,APCLBT,APCLCLX,APCLNAME,APCLDFN,APCLVDT))
IF APCLVDT=""
QUIT
SET APCLVDFN=0
DO SET5
+7 QUIT
SET5 ;
+1 FOR
SET APCLVDFN=$ORDER(^XTMP("APCLADA",APCLJOB,APCLBT,APCLCLX,APCLNAME,APCLDFN,APCLVDT,APCLVDFN))
IF APCLVDFN=""!(APCLSTOP="^")
QUIT
DO PRNT
+2 QUIT
PRNT ;
+1 ;increment visit count
SET APCLVTOT=APCLVTOT+1
+2 IF APCLFVS
WRITE !
IF $Y>(IOSL-5)
DO PAGE
IF APCLSTOP="^"
QUIT
+3 SET APCLPOVC=0
SET APCLFVS=1
SET APCLFPV=0
+4 WRITE ?26,$EXTRACT(APCLVDT,4,5),"/",$EXTRACT(APCLVDT,6,7),"/",$EXTRACT(APCLVDT,2,3)_" "_$EXTRACT($PIECE(APCLVDT,".",2)_"0000",1,4)
+5 ;
+6 ;set and print provider class code
+7 SET APCLPRV=0
PRV SET APCLPRV=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCLPRV))
+1 IF APCLPRV=""
SET APCLPV=0
SET APCLPOVC=0
KILL APCLNARR
GOTO POV
+2 IF '$DATA(^AUPNVPRV(APCLPRV,0))
GOTO PRV
IF $PIECE(^(0),"^",4)'="P"
GOTO PRV
+3 SET X=+^AUPNVPRV(APCLPRV,0)
+4 IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
SET X=$PIECE(^DIC(6,X,0),"^",4)
SET APCLCLS=$SELECT(X="":"",'$DATA(^DIC(7,X,9999999)):"",1:$PIECE(^DIC(7,X,9999999),"^"))
+5 IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
SET APCLCLS=$$PROVCLSC^XBFUNC1(X)
+6 WRITE ?41,APCLCLS
+7 ;
+8 ;
+9 SET APCLPV=0
SET APCLPOVC=0
KILL APCLNARR
POV SET APCLPV=$ORDER(^AUPNVPOV("AD",APCLVDFN,APCLPV))
+1 IF APCLPV=""
SET APCLVDEN=0
SET APCLPOVC=1
GOTO ADA
+2 IF '$DATA(^AUPNVPOV(APCLPV,0))
GOTO POV
SET APCLSTR=^(0)
+3 SET APCLNAR=$$VAL^XBDIQ1(9000010.07,APCLPV,.04)
+4 ;S APCLNAR=$S(APCLNAR="":"",$D(^AUTNPOV(APCLNAR,0)):$P(^(0),"^"),1:"")
+5 SET APCLPOVC=APCLPOVC+1
+6 SET APCLNARR(APCLPOVC)=$EXTRACT(APCLNAR,1,26)
+7 GOTO POV
+8 ;
+9 ;set and print procedures
ADA SET APCLVDEN=$ORDER(^AUPNVDEN("AD",APCLVDFN,APCLVDEN))
+1 IF APCLVDEN=""
QUIT
+2 IF '$DATA(^AUPNVDEN(APCLVDEN,0))
GOTO ADA
SET APCLSTR=^(0)
+3 SET APCLADA=+APCLSTR
+4 SET APCLADA=$SELECT(APCLADA="":"",1:$PIECE(^AUTTADA(APCLADA,0),"^"))
+5 IF APCLFPV
WRITE !
IF $Y>(IOSL-5)
DO PAGE
IF APCLSTOP="^"
QUIT
WRITE !
+6 IF 'APCLFPV
SET APCLFPV=1
+7 WRITE ?45,APCLADA,?53,$SELECT($DATA(APCLNARR(APCLPOVC)):APCLNARR(APCLPOVC),1:"")
SET APCLPOVC=APCLPOVC+1
+8 GOTO ADA
+9 ;
FINAL ;print grand totals
+1 IF APCLCL'="A"
GOTO END
+2 DO HEAD
+3 WRITE !!?39,"TOTAL PATIENTS: ",APCLPGRD
+4 WRITE !!?41,"TOTAL VISITS: ",APCLVGRA
+5 QUIT
+6 ;
TOTALS ;print totals
+1 IF $Y>(IOSL-5)
DO PAGE
+2 WRITE !!?28,"TOTAL PATIENTS FOR CLINIC: ",APCLPTOT
+3 WRITE !!?30,"TOTAL VISITS FOR CLINIC: ",APCLVTOT
+4 SET APCLPGRD=APCLPGRD+APCLPTOT
SET APCLVGRA=APCLVGRA+APCLVTOT
+5 IF IOST'?1"C-".E
QUIT
+6 ;R !!,"Enter <return> to continue or '^' to stop",APCLSTOP:DTIME
+7 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET APCLSTOP="^"
QUIT
+8 QUIT
+9 ;
HEAD ;
+1 IF $DATA(IOF)
WRITE @IOF,!?11,"*****Confidential Patient Data Covered by Privacy Act*****",!
+2 SET X=$PIECE(^DIC(4,DUZ(2),0),"^")
SET APCLPAGE=APCLPAGE+1
+3 WRITE !!,$PIECE(^VA(200,DUZ,0),"^",2),?(80-$LENGTH(X)/2),X,?72,"Page ",APCLPAGE
+4 SET X=$PIECE($HOROLOG,",",2)
DO TIME
WRITE !,Y
+5 IF $GET(APCLCLX)=""
SET X="No Clinic data to report"
GOTO HD1
+6 IF APCLCLX="E"
SET X="VISITS WITH NO ASSIGNED CLINIC CODE"
GOTO HD1
+7 IF APCLCLX]""
SET X="CLINIC VISITS FOR "_$PIECE(^DIC(40.7,APCLCLX,0),"^")_" ("_$PIECE(^(0),"^",2)_")"
WRITE ?(80-$LENGTH(X)/2),X
HD1 SET Y=DT
XECUTE ^DD("DD")
WRITE !,Y
+1 ;begin Y2K
+2 ;W ?28,"for ",$E(APCLBD,4,5),"/",$E(APCLBD,6,7),"/",$E(APCLBD,2,3) ;Y2000
+3 ;W " to ",$E(APCLED,4,5),"/",$E(APCLED,6,7),"/",$E(APCLED,2,3) ;Y2000
+4 ;Y2000
WRITE ?23,"for ",$$FMTE^XLFDT(APCLBD)," to ",$$FMTE^XLFDT(APCLED)
+5 ;end Y2K
+6 WRITE !!,"NAME",?16,"HRCN",?22,"AGE",?27,"VISIT DATE",?41,"PRV",?46,"ADA",?53,"PROV NARRATIVE",!
+7 QUIT
+8 ;
PAGE ;form feed to new page
+1 IF IOST'?1"C-".E
DO HEAD
QUIT
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCLSTOP="^"
QUIT
+3 IF APCLSTOP'="^"
DO HEAD
+4 QUIT
TIME SET Y=""
IF '$DATA(X)
QUIT
IF X<0!(X>86400)
QUIT
+1 SET %A=X\60
SET %B=%A\60
IF %B>12
SET %B=%B-12
IF %B=0
SET %B=12
IF %B<10
SET %B=" "_%B
+2 SET %C=$SELECT(%A=0:"M ",%A=720:"N ",%A=1440:"M ",%A<720:"am",1:"pm")
+3 SET Y=%B_":"_$EXTRACT(%A#60+100,2,3)_" "_%C
KILL %A,%B,%C
QUIT
