APCLYV52 ; IHS/CMI/LAB - PRINT INPATIENT VISITS ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 9/12/2007 code set versioning POV,PRC
;
INIT ;initialize variables
I '$D(^XTMP("APCLYV5",APCLJOB,APCLBTH,"VISITS")) S APCLPAGE=0 D HEAD W !!,"No Hospitaliations to report." G END
S APCLSTOP="",APCLPAGE=0
S (APCLPTOT,APCLVTOT)=0 ;patient and visit counts
;
SET ;
S APCLSORT=0 D HEAD
SET1 S APCLSORT=$O(^XTMP("APCLYV5",APCLJOB,APCLBTH,"VISITS",APCLSORT)) G FINAL:APCLSORT="" S APCLDFN=0
SET2 S APCLDFN=$O(^XTMP("APCLYV5",APCLJOB,APCLBTH,"VISITS",APCLSORT,APCLDFN)) G SET1:APCLDFN=""
S (APCLDDT,APCLFVS)=0
;set and print demographic data
S APCLPTOT=APCLPTOT+1
I $G(APCLLOC)]"",$D(^AUPNPAT(APCLDFN,41,APCLLOC,0)) S APCLHRCN=$P(^AUPNPAT(APCLDFN,41,APCLLOC,0),U,2) G SET21
S APCLHRCN=$S($D(^AUPNPAT(APCLDFN,41,DUZ(2),0)):$P(^(0),U,2),1:"")
SET21 K ^UTILITY("DIQ1",$J) S DIC=9000001,DA=APCLDFN,DR=1102.99 D EN^DIQ1
S APCLNAME=$P(^DPT(APCLDFN,0),U)
S APCLAGE=$G(^UTILITY("DIQ1",$J,9000001,APCLDFN,1102.99)) K ^UTILITY("DIQ1",$J)
I $Y>(IOSL-5) D PAGE G END:APCLSTOP="^"
W !,$E(APCLNAME,1,15),?16,$J(APCLHRCN,6),?24,$J(APCLAGE,2)
;
;find visit
SET3 S APCLDDT=$O(^XTMP("APCLYV5",APCLJOB,APCLBTH,"VISITS",APCLSORT,APCLDFN,APCLDDT)) G SET2:APCLDDT="" S APCLVDFN=$P(^(APCLDDT),"^"),APCLVDT=$P(^(APCLDDT),"^",2)
S APCLVTOT=APCLVTOT+1 ;increment visit count
I APCLFVS W ! I $Y>(IOSL-5) D PAGE G END:APCLSTOP="^"
S APCLFPV=0,APCLFVS=1
W ?27,$E(APCLVDT,4,5),"/",$E(APCLVDT,6,7),"/",$E(APCLVDT,2,3)
W "-",$E(APCLDDT,4,5),"/",$E(APCLDDT,6,7),"/",$E(APCLDDT,2,3)
;
;set and print provider class code
S APCLPRV=0
PRV S APCLPRV=$O(^AUPNVPRV("AD",APCLVDFN,APCLPRV))
I APCLPRV="" S APCLPV=0 G POV
G PRV:'$D(^AUPNVPRV(APCLPRV,0)),PRV:$P(^(0),"^",4)'="P"
S X=+^AUPNVPRV(APCLPRV,0)
S APCLCLS=$$PROVCLSC^XBFUNC1(X)
PRV1 W ?46,APCLCLS
;
S APCLPV=0
POV S APCLPV=$O(^AUPNVPOV("AD",APCLVDFN,APCLPV))
I APCLPV="" S APCLVPRC=0 G PRC
G POV:'$D(^AUPNVPOV(APCLPV,0)) S APCLSTR=^(0)
S APCLVRV=$P(APCLSTR,"^",8),APCLPS=$P(APCLSTR,"^",12)
S APCLVPOV=+APCLSTR,APCLNAR=$P(APCLSTR,"^",4)
S APCLVPOV=$S(APCLVPOV="":"",1:$P($$ICDDX^ICDEX(APCLVPOV),"^",2)) ;cmi/anch/maw 9/12/2007 csv
S APCLNAR=$$VAL^XBDIQ1(9000010.07,APCLPV,.04) ;$S(APCLNAR="":"",$D(^AUTNPOV(APCLNAR,0)):$P(^(0),"^"),1:"")
I APCLFPV W ! I $Y>(IOSL-5) D PAGE G END:APCLSTOP="^" W !
I 'APCLFPV S APCLFPV=1
W ?51,APCLVPOV,?61,$E(APCLNAR,1,18)
G POV
;
;set and print procedures
PRC S APCLVPRC=$O(^AUPNVPRC("AD",APCLVDFN,APCLVPRC))
I APCLVPRC="" W ! G SET3
G PRC:'$D(^AUPNVPRC(APCLVPRC,0)) S APCLSTR=^(0)
S APCLVRV=$P(APCLSTR,"^",8),APCLPS=$P(APCLSTR,"^",12)
S APCLPRC=+APCLSTR,APCLNAR=$P(APCLSTR,"^",4)
;S APCLPRC=$S(APCLPRC="":"",1:$P(^ICD0(APCLPRC,0),"^")) ;cmi/anch/maw 9/12/2007 orig line
S APCLPRC=$S(APCLPRC="":"",1:$P($$ICDOP^ICDEX(APCLPRC,,,"I"),"^",2)) ;cmi/anch/maw 9/12/2007 csv
S APCLNAR=$S(APCLNAR="":"",$D(^AUTNPOV(APCLNAR,0)):$P(^(0),"^"),1:"")
I APCLFPV W ! I $Y>(IOSL-5) D PAGE G END:APCLSTOP="^" W !
I 'APCLFPV S APCLFPV=1
W ?51,APCLPRC,?61,$E(APCLNAR,1,18)
G PRC
;
FINAL ;
I $Y>(IOSL-5) D PAGE
W !!?39,"TOTAL PATIENTS: ",APCLPTOT
W !!?41,"TOTAL VISITS: ",APCLVTOT
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="E" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLSTOP="^" G END
END ;
D DONE^APCLOSUT
K APCL65,APCLBD,APCLCLS,APCLED,APCLFPV,APCLFVS,APCLIOM,APCLMCR,%DT,%Y,%T,APCLAGE,DA,APCLDFN,APCLDDT,APCLIDFN,G,POP,APCLNAME
K APCLSORT,APCLNAR,APCLPRC,APCLPRV,APCLPS,APCLPTOT,APCLPV,A,APCLSTR
K APCLSTOP,APCLVDFN,APCLVDT,APCLVPOV,APCLVPRC,APCLVRV,APCLVTOT,Y
K APCLVTOT,APCLPAGE,APCLICD,APCLBICD,APCLEICD,APCLPV,APCLPRC,APCLFLG,APCLLOC
K ^XTMP("APCLYV5",APCLJOB,APCLBTH,"VISITS"),^XTMP("APCLYV5",APCLJOB,APCLBTH,"ICD") Q
;
HEAD ;
W:$D(IOF) @IOF,!?11,"*****Confidential Patient Data Covered by Privacy Act*****",!
S X=$P(^DIC(4,APCLLOC,0),"^"),APCLPAGE=APCLPAGE+1
W !!,$P(^VA(200,DUZ,0),"^",2),?(80-$L(X)/2),X,?70,"Page ",APCLPAGE
S X=$P($H,",",2) D TIME W !,Y,?27,"HOSPITALIZATION ",APCLTITL
S Y=DT X ^DD("DD") W !,Y
W ?26,"for ",$E(APCLBD,4,5),"/",$E(APCLBD,6,7),"/",(1700+$E(APCLBD,1,3)) ;IHS/CMI/LAB - 4 digit year
W " to ",$E(APCLED,4,5),"/",$E(APCLED,6,7),"/",(1700+$E(APCLED,1,3)) ;IHS/CMI/LAB - 4 digit year
S APCLLENG=$L($S(APCLSV=0:3,1:$P(^DIC(45.7,APCLSV,0),U)))
W !?(80-(22+APCLLENG)/2),$S(APCLSV=0:"ALL",1:$P(^DIC(45.7,APCLSV,0),U))," TREATING SPECIALT"_$S(APCLSV=0:"IES",1:"Y")
W !!,"NAME",?17,"HRCN",?23,"AGE",?28,"VISIT DATES",?46,"PRV",?51,"ICD",?61,"PROV NARRATIVE",!
Q
;
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 NEW %A,%B,%C 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
APCLYV52 ; IHS/CMI/LAB - PRINT INPATIENT VISITS ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 9/12/2007 code set versioning POV,PRC
+4 ;
INIT ;initialize variables
+1 IF '$DATA(^XTMP("APCLYV5",APCLJOB,APCLBTH,"VISITS"))
SET APCLPAGE=0
DO HEAD
WRITE !!,"No Hospitaliations to report."
GOTO END
+2 SET APCLSTOP=""
SET APCLPAGE=0
+3 ;patient and visit counts
SET (APCLPTOT,APCLVTOT)=0
+4 ;
SET ;
+1 SET APCLSORT=0
DO HEAD
SET1 SET APCLSORT=$ORDER(^XTMP("APCLYV5",APCLJOB,APCLBTH,"VISITS",APCLSORT))
IF APCLSORT=""
GOTO FINAL
SET APCLDFN=0
SET2 SET APCLDFN=$ORDER(^XTMP("APCLYV5",APCLJOB,APCLBTH,"VISITS",APCLSORT,APCLDFN))
IF APCLDFN=""
GOTO SET1
+1 SET (APCLDDT,APCLFVS)=0
+2 ;set and print demographic data
+3 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 SET21
+5 SET APCLHRCN=$SELECT($DATA(^AUPNPAT(APCLDFN,41,DUZ(2),0)):$PIECE(^(0),U,2),1:"")
SET21 KILL ^UTILITY("DIQ1",$JOB)
SET DIC=9000001
SET DA=APCLDFN
SET DR=1102.99
DO EN^DIQ1
+1 SET APCLNAME=$PIECE(^DPT(APCLDFN,0),U)
+2 SET APCLAGE=$GET(^UTILITY("DIQ1",$JOB,9000001,APCLDFN,1102.99))
KILL ^UTILITY("DIQ1",$JOB)
+3 IF $Y>(IOSL-5)
DO PAGE
IF APCLSTOP="^"
GOTO END
+4 WRITE !,$EXTRACT(APCLNAME,1,15),?16,$JUSTIFY(APCLHRCN,6),?24,$JUSTIFY(APCLAGE,2)
+5 ;
+6 ;find visit
SET3 SET APCLDDT=$ORDER(^XTMP("APCLYV5",APCLJOB,APCLBTH,"VISITS",APCLSORT,APCLDFN,APCLDDT))
IF APCLDDT=""
GOTO SET2
SET APCLVDFN=$PIECE(^(APCLDDT),"^")
SET APCLVDT=$PIECE(^(APCLDDT),"^",2)
+1 ;increment visit count
SET APCLVTOT=APCLVTOT+1
+2 IF APCLFVS
WRITE !
IF $Y>(IOSL-5)
DO PAGE
IF APCLSTOP="^"
GOTO END
+3 SET APCLFPV=0
SET APCLFVS=1
+4 WRITE ?27,$EXTRACT(APCLVDT,4,5),"/",$EXTRACT(APCLVDT,6,7),"/",$EXTRACT(APCLVDT,2,3)
+5 WRITE "-",$EXTRACT(APCLDDT,4,5),"/",$EXTRACT(APCLDDT,6,7),"/",$EXTRACT(APCLDDT,2,3)
+6 ;
+7 ;set and print provider class code
+8 SET APCLPRV=0
PRV SET APCLPRV=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCLPRV))
+1 IF APCLPRV=""
SET APCLPV=0
GOTO POV
+2 IF '$DATA(^AUPNVPRV(APCLPRV,0))
GOTO PRV
IF $PIECE(^(0),"^",4)'="P"
GOTO PRV
+3 SET X=+^AUPNVPRV(APCLPRV,0)
+4 SET APCLCLS=$$PROVCLSC^XBFUNC1(X)
PRV1 WRITE ?46,APCLCLS
+1 ;
+2 SET APCLPV=0
POV SET APCLPV=$ORDER(^AUPNVPOV("AD",APCLVDFN,APCLPV))
+1 IF APCLPV=""
SET APCLVPRC=0
GOTO PRC
+2 IF '$DATA(^AUPNVPOV(APCLPV,0))
GOTO POV
SET APCLSTR=^(0)
+3 SET APCLVRV=$PIECE(APCLSTR,"^",8)
SET APCLPS=$PIECE(APCLSTR,"^",12)
+4 SET APCLVPOV=+APCLSTR
SET APCLNAR=$PIECE(APCLSTR,"^",4)
+5 ;cmi/anch/maw 9/12/2007 csv
SET APCLVPOV=$SELECT(APCLVPOV="":"",1:$PIECE($$ICDDX^ICDEX(APCLVPOV),"^",2))
+6 ;$S(APCLNAR="":"",$D(^AUTNPOV(APCLNAR,0)):$P(^(0),"^"),1:"")
SET APCLNAR=$$VAL^XBDIQ1(9000010.07,APCLPV,.04)
+7 IF APCLFPV
WRITE !
IF $Y>(IOSL-5)
DO PAGE
IF APCLSTOP="^"
GOTO END
WRITE !
+8 IF 'APCLFPV
SET APCLFPV=1
+9 WRITE ?51,APCLVPOV,?61,$EXTRACT(APCLNAR,1,18)
+10 GOTO POV
+11 ;
+12 ;set and print procedures
PRC SET APCLVPRC=$ORDER(^AUPNVPRC("AD",APCLVDFN,APCLVPRC))
+1 IF APCLVPRC=""
WRITE !
GOTO SET3
+2 IF '$DATA(^AUPNVPRC(APCLVPRC,0))
GOTO PRC
SET APCLSTR=^(0)
+3 SET APCLVRV=$PIECE(APCLSTR,"^",8)
SET APCLPS=$PIECE(APCLSTR,"^",12)
+4 SET APCLPRC=+APCLSTR
SET APCLNAR=$PIECE(APCLSTR,"^",4)
+5 ;S APCLPRC=$S(APCLPRC="":"",1:$P(^ICD0(APCLPRC,0),"^")) ;cmi/anch/maw 9/12/2007 orig line
+6 ;cmi/anch/maw 9/12/2007 csv
SET APCLPRC=$SELECT(APCLPRC="":"",1:$PIECE($$ICDOP^ICDEX(APCLPRC,,,"I"),"^",2))
+7 SET APCLNAR=$SELECT(APCLNAR="":"",$DATA(^AUTNPOV(APCLNAR,0)):$PIECE(^(0),"^"),1:"")
+8 IF APCLFPV
WRITE !
IF $Y>(IOSL-5)
DO PAGE
IF APCLSTOP="^"
GOTO END
WRITE !
+9 IF 'APCLFPV
SET APCLFPV=1
+10 WRITE ?51,APCLPRC,?61,$EXTRACT(APCLNAR,1,18)
+11 GOTO PRC
+12 ;
FINAL ;
+1 IF $Y>(IOSL-5)
DO PAGE
+2 WRITE !!?39,"TOTAL PATIENTS: ",APCLPTOT
+3 WRITE !!?41,"TOTAL VISITS: ",APCLVTOT
+4 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="^"
GOTO END
END ;
+1 DO DONE^APCLOSUT
+2 KILL APCL65,APCLBD,APCLCLS,APCLED,APCLFPV,APCLFVS,APCLIOM,APCLMCR,%DT,%Y,%T,APCLAGE,DA,APCLDFN,APCLDDT,APCLIDFN,G,POP,APCLNAME
+3 KILL APCLSORT,APCLNAR,APCLPRC,APCLPRV,APCLPS,APCLPTOT,APCLPV,A,APCLSTR
+4 KILL APCLSTOP,APCLVDFN,APCLVDT,APCLVPOV,APCLVPRC,APCLVRV,APCLVTOT,Y
+5 KILL APCLVTOT,APCLPAGE,APCLICD,APCLBICD,APCLEICD,APCLPV,APCLPRC,APCLFLG,APCLLOC
+6 KILL ^XTMP("APCLYV5",APCLJOB,APCLBTH,"VISITS"),^XTMP("APCLYV5",APCLJOB,APCLBTH,"ICD")
QUIT
+7 ;
HEAD ;
+1 IF $DATA(IOF)
WRITE @IOF,!?11,"*****Confidential Patient Data Covered by Privacy Act*****",!
+2 SET X=$PIECE(^DIC(4,APCLLOC,0),"^")
SET APCLPAGE=APCLPAGE+1
+3 WRITE !!,$PIECE(^VA(200,DUZ,0),"^",2),?(80-$LENGTH(X)/2),X,?70,"Page ",APCLPAGE
+4 SET X=$PIECE($HOROLOG,",",2)
DO TIME
WRITE !,Y,?27,"HOSPITALIZATION ",APCLTITL
+5 SET Y=DT
XECUTE ^DD("DD")
WRITE !,Y
+6 ;IHS/CMI/LAB - 4 digit year
WRITE ?26,"for ",$EXTRACT(APCLBD,4,5),"/",$EXTRACT(APCLBD,6,7),"/",(1700+$EXTRACT(APCLBD,1,3))
+7 ;IHS/CMI/LAB - 4 digit year
WRITE " to ",$EXTRACT(APCLED,4,5),"/",$EXTRACT(APCLED,6,7),"/",(1700+$EXTRACT(APCLED,1,3))
+8 SET APCLLENG=$LENGTH($SELECT(APCLSV=0:3,1:$PIECE(^DIC(45.7,APCLSV,0),U)))
+9 WRITE !?(80-(22+APCLLENG)/2),$SELECT(APCLSV=0:"ALL",1:$PIECE(^DIC(45.7,APCLSV,0),U))," TREATING SPECIALT"_$SELECT(APCLSV=0:"IES",1:"Y")
+10 WRITE !!,"NAME",?17,"HRCN",?23,"AGE",?28,"VISIT DATES",?46,"PRV",?51,"ICD",?61,"PROV NARRATIVE",!
+11 QUIT
+12 ;
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 NEW %A,%B,%C
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
