Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLYV22

APCLYV22.m

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