- 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