APCLYV22 ; IHS/CMI/LAB - PRINT OUTPT VISITS WITH ICD CODES ;
;;2.0;IHS PCC SUITE;**11,21**;MAY 14, 2009;Build 34
;IHS/CMI/LAB - y2k
;
;cmi/anch/maw 9/12/2007 code set versioning POV,PRC
;
INIT ;initialize variables
S APCLIOM=IOM,X=132 X ^%ZOSF("RM")
S APCLPAGE=0 I '$D(^XTMP("APCLYV2",APCLJOB,APCLBT)) D HEAD W !!,"NO DATA TO REPORT" G END
S (APCLPTOT,APCLVTOT)=0
S APCLSTOP="",APCLPAGE=0
;
SET ;set up print fields
S APCLNAME=0 D HEAD
SET1 S APCLNAME=$O(^XTMP("APCLYV2",APCLJOB,APCLBT,APCLNAME)) G TOTALS:APCLNAME="" S APCLDFN=0
SET2 S APCLDFN=$O(^XTMP("APCLYV2",APCLJOB,APCLBT,APCLNAME,APCLDFN)) G SET1:APCLDFN=""
S (APCLVDT,APCLFVS)=0
;
S APCLPTOT=APCLPTOT+1 ;increment patient count
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 ;
;begin Y2K
;S X=$P(^DPT(APCLDFN,0),"^",3),APCLDOB=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) ;Y2000
S X=$P(^DPT(APCLDFN,0),"^",3),APCLDOB=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+($E(X,1,3))) ;Y2000
;end Y2K
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)
S APCL65=$S('$D(APCLAGE):"",APCLAGE>64:"*",1:"")
S APCLSEX=$P(^DPT(APCLDFN,0),"^",2),(APCLMCR,APCLSFX)=""
I $D(^AUPNMCR(APCLDFN,0)) S APCLMCR=$$GETMCR^AGUTL(APCLDFN),APCLSFX=$P(^(0),"^",4) ;IHS/CMI/LAB PATCH 21 NMCI
S APCLMCR=APCLMCR_$S(APCLSFX="":"",$D(^AUTTMCS(APCLSFX,0)):$P(^(0),"^"),1:"")
I $Y>(IOSL-5) D PAGE G END:APCLSTOP="^"
W !,$E(APCLNAME,1,20),?22,$J(APCLHRCN,6),?31,APCL65,?32,APCLDOB,?43,APCLMCR
;
;find visit
SET3 S APCLVDT=$O(^XTMP("APCLYV2",APCLJOB,APCLBT,APCLNAME,APCLDFN,APCLVDT)) G SET2:APCLVDT="" S APCLVDFN=0
SET4 S APCLVDFN=$O(^XTMP("APCLYV2",APCLJOB,APCLBT,APCLNAME,APCLDFN,APCLVDT,APCLVDFN)) G SET3:APCLVDFN=""
S APCLVTOT=APCLVTOT+1 ;increment visit count
I APCLFVS W ! I $Y>(IOSL-5) D PAGE G END:APCLSTOP="^"
S APCLFPV=0,APCLFVS=1
;begin Y2K
;W ?57,$E(APCLVDT,4,5),"/",$E(APCLVDT,6,7),"/",$E(APCLVDT,2,3) ;Y2000
W ?57,$E(APCLVDT,4,5),"/",$E(APCLVDT,6,7),"/",(1700+($E(APCLVDT,1,3))) ;Y2000
;end Y2K
;
;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)
I $P(^DD(9000010.06,.01,0),U,2)[200 S APCLCLS=$$PROVCLS^XBFUNC1(X) G PRV1
S X=$P(^DIC(6,X,0),"^",4)
S APCLCLS=$S(X="":"",'$D(^DIC(7,X,9999999)):"??",1:$P(^DIC(7,X,9999999),"^"))
PRV1 W ?69,$E(APCLCLS,1,3)
;
;set POV variables
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)
S APCLVPOV=+APCLSTR,APCLNAR=$P(APCLSTR,"^",4)
;S APCLVPOV=$S(APCLVPOV="":"",1:$P(^ICD9(APCLVPOV,0),"^")) ;cmi/anch/maw 9/12/2007 orig line
S APCLVPOV=$S(APCLVPOV="":"",1:$P($$ICDDX^ICDEX(APCLVPOV,,,"I"),"^",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 ?74,APCLVRV,?77,APCLVPOV,?87,$E(APCLNAR,1,45)
G POV
;
;set and print procedures
PRC S APCLVPRC=$O(^AUPNVPRC("AD",APCLVDFN,APCLVPRC)) G SET4:APCLVPRC=""
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 ?73,APCLVRV,?76,"*",APCLPRC,?87,$E(APCLNAR,1,45)
G PRC
TOTALS ;print totals
I $Y>(IOSL-7) D PAGE
W !!?39,"TOTAL PATIENTS: ",APCLPTOT
W !!?40,"TOTALS VISITS: ",APCLVTOT
END ;
D DONE^APCLOSUT
W:$D(IOF) @IOF S X=APCLIOM X ^%ZOSF("RM")
K APCL65,APCLBD,APCLCLS,APCLED,APCLFPV,APCLFVS,APCLIOM,APCLMCR,APCLSTR,APCLDEN,Y,APCLPAGE,DA,APCLPS,%DT,APCLDFN
K APCLNAME,APCLNAR,APCLPRC,APCLPRV,APCLPTOT,APCLPV,A,POP
K APCLSTOP,APCLVDFN,APCLVDT,APCLVPOV,APCLVPRC,APCLVRV,APCLVTOT
K DIC,APCLDOB,DR,APCLHRCN,APCLAGE,APCLSEX,APCLSFX,APCLSTR,X
K ^XTMP("APCLYV2",APCLJOB,APCLBT)
Q
HEAD ;
W:$D(IOF) @IOF,!?37,"*****Confidential Patient Data Covered by Privacy Act*****"
W !!,$P(^VA(200,DUZ,0),"^",2)
S X=$P(^DIC(4,DUZ(2),0),"^"),APCLPAGE=APCLPAGE+1
W ?(132-$L(X)/2),X,?122,"Page ",APCLPAGE
S Y=DT X ^DD("DD") W !,Y
W ?46,"ALL OUTPATIENT VISITS (exluding dental)"
;begin Y2K
;W !?54,"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 !?51,"for ",$E(APCLBD,4,5),"/",$E(APCLBD,6,7),"/",(1700+($E(APCLBD,1,3))) ;Y2000
W " to ",$E(APCLED,4,5),"/",$E(APCLED,6,7),"/",(1700+($E(APCLED,1,3))) ;Y2000
;end Y2K
W !!,"NAME",?23,"HRCN",?36,"DOB",?43,"MEDICARE #",?56,"VISIT DATE",?68,"PROV",?73,"F/R",?77,"ICD",?87,"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
D HEAD
Q
;
APCLYV22 ; IHS/CMI/LAB - PRINT OUTPT VISITS WITH ICD CODES ;
+1 ;;2.0;IHS PCC SUITE;**11,21**;MAY 14, 2009;Build 34
+2 ;IHS/CMI/LAB - y2k
+3 ;
+4 ;cmi/anch/maw 9/12/2007 code set versioning POV,PRC
+5 ;
INIT ;initialize variables
+1 SET APCLIOM=IOM
SET X=132
XECUTE ^%ZOSF("RM")
+2 SET APCLPAGE=0
IF '$DATA(^XTMP("APCLYV2",APCLJOB,APCLBT))
DO HEAD
WRITE !!,"NO DATA TO REPORT"
GOTO END
+3 SET (APCLPTOT,APCLVTOT)=0
+4 SET APCLSTOP=""
SET APCLPAGE=0
+5 ;
SET ;set up print fields
+1 SET APCLNAME=0
DO HEAD
SET1 SET APCLNAME=$ORDER(^XTMP("APCLYV2",APCLJOB,APCLBT,APCLNAME))
IF APCLNAME=""
GOTO TOTALS
SET APCLDFN=0
SET2 SET APCLDFN=$ORDER(^XTMP("APCLYV2",APCLJOB,APCLBT,APCLNAME,APCLDFN))
IF APCLDFN=""
GOTO SET1
+1 SET (APCLVDT,APCLFVS)=0
+2 ;
+3 ;increment patient count
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 ;
+1 ;begin Y2K
+2 ;S X=$P(^DPT(APCLDFN,0),"^",3),APCLDOB=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) ;Y2000
+3 ;Y2000
SET X=$PIECE(^DPT(APCLDFN,0),"^",3)
SET APCLDOB=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+($EXTRACT(X,1,3)))
+4 ;end Y2K
+5 KILL ^UTILITY("DIQ1",$JOB)
SET DIC=9000001
SET DA=APCLDFN
SET DR=1102.99
DO EN^DIQ1
+6 SET APCLAGE=$GET(^UTILITY("DIQ1",$JOB,9000001,APCLDFN,1102.99))
KILL ^UTILITY("DIQ1",$JOB)
+7 SET APCL65=$SELECT('$DATA(APCLAGE):"",APCLAGE>64:"*",1:"")
+8 SET APCLSEX=$PIECE(^DPT(APCLDFN,0),"^",2)
SET (APCLMCR,APCLSFX)=""
+9 ;IHS/CMI/LAB PATCH 21 NMCI
IF $DATA(^AUPNMCR(APCLDFN,0))
SET APCLMCR=$$GETMCR^AGUTL(APCLDFN)
SET APCLSFX=$PIECE(^(0),"^",4)
+10 SET APCLMCR=APCLMCR_$SELECT(APCLSFX="":"",$DATA(^AUTTMCS(APCLSFX,0)):$PIECE(^(0),"^"),1:"")
+11 IF $Y>(IOSL-5)
DO PAGE
IF APCLSTOP="^"
GOTO END
+12 WRITE !,$EXTRACT(APCLNAME,1,20),?22,$JUSTIFY(APCLHRCN,6),?31,APCL65,?32,APCLDOB,?43,APCLMCR
+13 ;
+14 ;find visit
SET3 SET APCLVDT=$ORDER(^XTMP("APCLYV2",APCLJOB,APCLBT,APCLNAME,APCLDFN,APCLVDT))
IF APCLVDT=""
GOTO SET2
SET APCLVDFN=0
SET4 SET APCLVDFN=$ORDER(^XTMP("APCLYV2",APCLJOB,APCLBT,APCLNAME,APCLDFN,APCLVDT,APCLVDFN))
IF APCLVDFN=""
GOTO SET3
+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 ;begin Y2K
+5 ;W ?57,$E(APCLVDT,4,5),"/",$E(APCLVDT,6,7),"/",$E(APCLVDT,2,3) ;Y2000
+6 ;Y2000
WRITE ?57,$EXTRACT(APCLVDT,4,5),"/",$EXTRACT(APCLVDT,6,7),"/",(1700+($EXTRACT(APCLVDT,1,3)))
+7 ;end Y2K
+8 ;
+9 ;set and print provider class code
+10 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 IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
SET APCLCLS=$$PROVCLS^XBFUNC1(X)
GOTO PRV1
+5 SET X=$PIECE(^DIC(6,X,0),"^",4)
+6 SET APCLCLS=$SELECT(X="":"",'$DATA(^DIC(7,X,9999999)):"??",1:$PIECE(^DIC(7,X,9999999),"^"))
PRV1 WRITE ?69,$EXTRACT(APCLCLS,1,3)
+1 ;
+2 ;set POV variables
+3 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)
+4 SET APCLVPOV=+APCLSTR
SET APCLNAR=$PIECE(APCLSTR,"^",4)
+5 ;S APCLVPOV=$S(APCLVPOV="":"",1:$P(^ICD9(APCLVPOV,0),"^")) ;cmi/anch/maw 9/12/2007 orig line
+6 ;cmi/anch/maw 9/12/2007 csv
SET APCLVPOV=$SELECT(APCLVPOV="":"",1:$PIECE($$ICDDX^ICDEX(APCLVPOV,,,"I"),"^",2))
+7 ;$S(APCLNAR="":"",$D(^AUTNPOV(APCLNAR,0)):$P(^(0),"^"),1:"")
SET APCLNAR=$$VAL^XBDIQ1(9000010.07,APCLPV,.04)
+8 IF APCLFPV
WRITE !
IF $Y>(IOSL-5)
DO PAGE
IF APCLSTOP="^"
GOTO END
WRITE !
+9 IF 'APCLFPV
SET APCLFPV=1
+10 WRITE ?74,APCLVRV,?77,APCLVPOV,?87,$EXTRACT(APCLNAR,1,45)
+11 GOTO POV
+12 ;
+13 ;set and print procedures
PRC SET APCLVPRC=$ORDER(^AUPNVPRC("AD",APCLVDFN,APCLVPRC))
IF APCLVPRC=""
GOTO SET4
+1 IF '$DATA(^AUPNVPRC(APCLVPRC,0))
GOTO PRC
SET APCLSTR=^(0)
+2 SET APCLVRV=$PIECE(APCLSTR,"^",8)
SET APCLPS=$PIECE(APCLSTR,"^",12)
+3 SET APCLPRC=+APCLSTR
SET APCLNAR=$PIECE(APCLSTR,"^",4)
+4 ;S APCLPRC=$S(APCLPRC="":"",1:$P(^ICD0(APCLPRC,0),"^")) ;cmi/anch/maw 9/12/2007 orig line
+5 ;cmi/anch/maw 9/12/2007 csv
SET APCLPRC=$SELECT(APCLPRC="":"",1:$PIECE($$ICDOP^ICDEX(APCLPRC,,,"I"),"^",2))
+6 SET APCLNAR=$SELECT(APCLNAR="":"",$DATA(^AUTNPOV(APCLNAR,0)):$PIECE(^(0),"^"),1:"")
+7 IF APCLFPV
WRITE !
IF $Y>(IOSL-5)
DO PAGE
IF APCLSTOP="^"
GOTO END
WRITE !
+8 IF 'APCLFPV
SET APCLFPV=1
+9 WRITE ?73,APCLVRV,?76,"*",APCLPRC,?87,$EXTRACT(APCLNAR,1,45)
+10 GOTO PRC
TOTALS ;print totals
+1 IF $Y>(IOSL-7)
DO PAGE
+2 WRITE !!?39,"TOTAL PATIENTS: ",APCLPTOT
+3 WRITE !!?40,"TOTALS VISITS: ",APCLVTOT
END ;
+1 DO DONE^APCLOSUT
+2 IF $DATA(IOF)
WRITE @IOF
SET X=APCLIOM
XECUTE ^%ZOSF("RM")
+3 KILL APCL65,APCLBD,APCLCLS,APCLED,APCLFPV,APCLFVS,APCLIOM,APCLMCR,APCLSTR,APCLDEN,Y,APCLPAGE,DA,APCLPS,%DT,APCLDFN
+4 KILL APCLNAME,APCLNAR,APCLPRC,APCLPRV,APCLPTOT,APCLPV,A,POP
+5 KILL APCLSTOP,APCLVDFN,APCLVDT,APCLVPOV,APCLVPRC,APCLVRV,APCLVTOT
+6 KILL DIC,APCLDOB,DR,APCLHRCN,APCLAGE,APCLSEX,APCLSFX,APCLSTR,X
+7 KILL ^XTMP("APCLYV2",APCLJOB,APCLBT)
+8 QUIT
HEAD ;
+1 IF $DATA(IOF)
WRITE @IOF,!?37,"*****Confidential Patient Data Covered by Privacy Act*****"
+2 WRITE !!,$PIECE(^VA(200,DUZ,0),"^",2)
+3 SET X=$PIECE(^DIC(4,DUZ(2),0),"^")
SET APCLPAGE=APCLPAGE+1
+4 WRITE ?(132-$LENGTH(X)/2),X,?122,"Page ",APCLPAGE
+5 SET Y=DT
XECUTE ^DD("DD")
WRITE !,Y
+6 WRITE ?46,"ALL OUTPATIENT VISITS (exluding dental)"
+7 ;begin Y2K
+8 ;W !?54,"for ",$E(APCLBD,4,5),"/",$E(APCLBD,6,7),"/",$E(APCLBD,2,3) ;Y2000
+9 ;W " to ",$E(APCLED,4,5),"/",$E(APCLED,6,7),"/",$E(APCLED,2,3) ;Y2000
+10 ;Y2000
WRITE !?51,"for ",$EXTRACT(APCLBD,4,5),"/",$EXTRACT(APCLBD,6,7),"/",(1700+($EXTRACT(APCLBD,1,3)))
+11 ;Y2000
WRITE " to ",$EXTRACT(APCLED,4,5),"/",$EXTRACT(APCLED,6,7),"/",(1700+($EXTRACT(APCLED,1,3)))
+12 ;end Y2K
+13 WRITE !!,"NAME",?23,"HRCN",?36,"DOB",?43,"MEDICARE #",?56,"VISIT DATE",?68,"PROV",?73,"F/R",?77,"ICD",?87,"PROV NARRATIVE",!
+14 QUIT
+15 ;
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 DO HEAD
+4 QUIT
+5 ;
