10:52 AM 2-NOV-98 PCC MANAGEMENT REPORTS PATCH 3 (includes patches 1-3) APCL1A APCL1A ; IHS/OHPRD/TMJ - APC visits by primary provider ; [ 11/02/98 10:46 AM ] ;;3.0;IHS PCC REPORTS;**3**;FEB 05, 1997 ;CMI/TUCSON/LAB patch 3 10/26/1998 made Y2K fixes START ; D INFORM K DUOUT,DTOUT FY D ^APCLFY I $D(DTOUT)!(Y=-1) G EOJ ;beginning Y2K. CMI/TUCSON/LAB Commented out F-2 and F-1. Fixed one line. Added one line. I DTAPCL("FY END DATE")) W !!?6,"Current FISCAL Year date range: ",APCL("FY PRINTABLE BDATE")," - ",APCL("FY TODAY") I DTAPCL("FY END DATE")) %DT("B")=APCL("FY TODAY") ;Y2000 ;E S %DT("B")=APCL("FY PRINTABLE EDATE") ;Y2000 ;end Y2K CMI/TUCSON/LAB 10/26/98 F ; W !! S DIC("A")="Run for which Facility of Encounter: ",DIC="^AUTTLOC(",DIC(0)="AEMQ" D ^DIC K DIC,DA G:Y<0 FY S APCLLOC=+Y W !!,$C(7),$C(7),"THIS REPORT MUST BE PRINTED ON 132 COLUMN PAPER OR ON A PRINTER THAT IS",!,"SET UP FOR CONDENSED PRINT!!!",!,"IF YOU DO NOT HAVE SUCH A PRINTER AVAILABLE - SEE YOUR SITE MANAGER.",! ZIS ; S XBRP="^APCL1AP",XBRC="^APCL1A1",XBRX="EOJ^APCL1A",XBNS="APCL" D ^XBDBQUE D EOJ Q ERR W $C(7),$C(7),!,"Must be a valid Year. Enter a year only!!" Q EOJ K APCLFY,APCLLOC,APCLSD,APCLVDFN,APCLVREC,APCLSKIP,APCLCLIN,APCL1,APCL2,APCLDISC,APCLAP,APCLPPOV,APCLX,APCLDPTR,APCLVLOC,APCLMOL,APCLFYD,APCLMOS,APCLBT,APCLJOB K APCLDT,APCLAREA,APCLLOCP,APCLLOC,APCLAREC,APCLSU,APCLSUC,APCLGRAN,APCLPG,APCLQUIT,APCLMON,APCLTAB,APCLJ,APCLDISN,APCLPRIM,APCLP,APCLT,APCLPRIT,APCL132,APCLFYE,APCLLOCC,DFN K X,X1,X2,IO("Q"),%,Y,%DT,%Y,%W,%T,%H,DUOUT,DTOUT,POP,ZTSK,ZTQUEUED,H,S,TS,M Q ; INFORM ; W:$D(IOF) @IOF W !,"********** PCC/APC REPORT 1A **********",! W !,"This report will print Year to Date Ambulatory Visit Counts for the Facility",!,"and Fiscal Year that you select. The counts by month are for date of" W !,"service. This report will resemble, but not duplicate exactly, the",!,"APC 1A report produced at the IHS Data Center in Albuquerque.",!! Q ; ; APCL2A3 APCL2A3 ; IHS/OHPRD/TMJ - BODY MASS INDEX & RELATIVE WEIGHT FOR MEASUREMENT TRANSFORMS ; [ 06/02/97 3:46 PM ] ;;3.0;IHS PCC REPORTS;**1**;FEB 05, 1997 ;DL/IHS/TPA 12-2-91 ;IHS/TUCSON/LAB - patch 1 adds $G statement on error code 06/02/97 ; BMI(APCLPAT,APCLWT,APCLSDAT) ; ENTRY POINT - TO OBTAIN BODY MASS INDEX NEW APCLDOB,APCLSEX,APCLAGE,APCLSX,APCLHT,APCLBMI,APCLPRW,APCLSWT,APCLCOMT,APCLRW,APCLMDT,APCLDA ;------------ I (APCLWT="")!(APCLSDAT="")!(APCLPAT="") G ERROR ;------------ D COMMON G:$E(APCLCOMT)="!" ERROR S APCLWT=(APCLWT/5)*2.3,APCLHT=(APCLHT*2.5),APCLHT=(APCLHT*APCLHT)/10000,APCLBMI=(APCLWT/APCLHT),APCLBMI=$J(APCLBMI,5,1) S APCLSWT=APCLBMI_$S(APCLCOMT]"":" **",1:" ") G EXIT ; RW(APCLPAT,APCLWT,APCLSDAT) ; ENTRY POINT - TO OBTAIN RELATIVE WEIGHT PERCENTAGE NEW APCLDOB,APCLSEX,APCLAGE,APCLSX,APCLHT,APCLBMI,APCLPRW,APCLSWT,APCLCOMT,APCLRW,APCLMDT,APCLDA ;------------ I (APCLWT="")!(APCLSDAT="")!(APCLPAT="") G ERROR ;------------ D COMMON G:$E(APCLCOMT)="!" ERROR I (APCLHT>70)!(APCLHT<58)&(APCLSEX="F") S APCLCOMT="!HEIGHT OUT OF RANGE FOR SEX." G ERROR I (APCLHT>75)!(APCLHT<61)&(APCLSEX="M") S APCLCOMT="!HEIGHT OUT OF RANGE FOR SEX." G ERROR S APCLHT=APCLHT-57,APCLRW=$P($T(SIZES+APCLHT),";;",APCLSX),APCLPRW=(APCLWT*100/APCLRW)\1 S APCLSWT=APCLPRW_"%"_$S(APCLCOMT]"":" **",1:" ") G EXIT ERROR S:$G(APCLCOMT)="" APCLCOMT="" S APCLSWT="***",APCLCOMT="*** "_$E(APCLCOMT,2,$L(APCLCOMT)) ;IHS/TUCSON/LAB patch 1 added $G statement EXIT K X,X1,X2 ; note that the rest of the variables were NEWed S Y=APCLSWT_"^"_$G(APCLCOMT) K APCLDOB,APCLSEX,APCLAGE,APCLSX,APCLHT,APCLBMI,APCLPRW,APCLSWT,APCLCOMT,APCLRW,APCLMDT,APCLDA,APCLSDAT Q Y ; COMMON ;OBTAIN DOB, AGE, SEX, and COMN ;------------ I '$D(^AUPNVMSR("AA",APCLPAT,1)) S APCLCOMT="!NO HEIGHT FOR PATIENT." Q S APCLDOB=$P(^DPT(APCLPAT,0),U,3),APCLSEX=$P(^DPT(APCLPAT,0),U,2),X2=APCLDOB,X1=DT D ^%DTC S APCLAGE=X,APCLSX=$S(APCLSEX="M":2,APCLSEX="F":3,1:"") S APCLCOMT="" S APCLDA="" NXTHT S APCLDA=$O(^AUPNVMSR("AA",APCLPAT,1,APCLSDAT,"")) G:APCLDA]"" HITE NXTDATE S APCLSDAT=$O(^AUPNVMSR("AA",APCLPAT,1,APCLSDAT)) G:APCLSDAT]"" NXTHT S APCLCOMT="!NO HEIGHT FOUND." Q HITE S X1=9999999-(APCLSDAT\1),X2=APCLDOB D ^%DTC S APCLMDT=X S APCLHT=$P(^AUPNVMSR(APCLDA,0),U,4),X1=DT,X2=9999999-(APCLSDAT\1) D ^%DTC I ((X>90)&(APCLAGE<1096))!((X>180)&(APCLAGE<4381))!((X>365)&(APCLAGE<6571))!((APCLMDT<6571)&(APCLAGE>6571)) S APCLCOMT="** HEIGHT MAY BE OLD." Q ; ;; TEMPORARY ENTRY POINTS UNTIL FILEMAN WILL ACCEPT $$FUNCTIONS ; SIZES ;; ;;;;107 ;;;;110 ;;;;113 ;;120;;116 ;;123;;119 ;;126;;123 ;;130;;126 ;;133;;130 ;;138;;134 ;;142;;138 ;;146;;143 ;;150;;147 ;;155;;152 ;;159 ;;164 ;;168 ;;173 ;;177 APCLAA APCLAA ; IHS/OHPRD/TMJ - APC visits by primary provider ; [ 11/02/98 10:47 AM ] ;;3.0;IHS PCC REPORTS;**3**;FEB 05, 1997 ;CMI/TUCSON/LAB - patch 3 10/26/1998 Y2K fixes START ; D INFORM K DUOUT,DTOUT FY W !! D ^APCLFY I $D(DTOUT)!(Y=-1) G EOJ ;beginning Y2K. CMI/TUCSON/LAB Commented out F-2 and F-1. Fixed one line. Added one line. I DTAPCL("FY END DATE")) W !!?6,"Current FISCAL Year date range: ",APCL("FY PRINTABLE BDATE")," - ",APCL("FY TODAY") I DTAPCL("FY END DATE")) %DT("B")=APCL("FY TODAY") ;Y2000 ;E S %DT("B")=APCL("FY PRINTABLE EDATE") ;Y2000 ;end Y2K CMI/TUCSON/LAB patch 3 F ; W ! S DIC("A")="Run for which Facility of Encounter: ",DIC="^AUTTLOC(",DIC(0)="AEMQ" D ^DIC K DIC,DA G:Y<0 FY S APCLLOC=+Y W !!,$C(7),$C(7),"THIS REPORT MUST BE PRINTED ON 132 COLUMN PAPER OR ON A PRINTER THAT IS",!,"SET UP FOR CONDENSED PRINT!!!,",!,"IF YOU DO NOT HAVE SUCH A PRINTER AVAILABLE - SEE YOUR SITE MANAGER.",! ZIS ; S XBRP="^APCLAAP",XBRC="^APCLAA1",XBRX="EOJ^APCLAA",XBNS="APCL" D ^XBDBQUE D EOJ Q ERR W $C(7),$C(7),!,"Must be a valid Year. Enter a year only!!," Q EOJ K APCLFY,APCLLOC,APCLSD,APCLVDFN,APCLVREC,APCLSKIP,APCLCLIN,APCL1,APCL2,APCLDISC,APCLAP,APCLPPOV,APCLX,APCLDPTR,APCLVLOC,APCLMOL,APCLFYD,APCLMOS,APCLBT,APCLJOB K APCLDT,APCLAREA,APCLLOCP,APCLLOC,APCLAREC,APCLSU,APCLSUC,APCLGRAN,APCLPG,APCLQUIT,APCLMON,APCLTAB,APCLJ,APCLDISN,APCLPRIM,APCLP,APCLT,APCLPRIT,APCL132,APCLFYE,APCLLOCC,DFN K X,X1,X2,IO("Q"),%,Y,%DT,%Y,%W,%T,%H,DUOUT,DTOUT,POP,ZTSK,ZTQUEUED,H,S,TS,M Q ; INFORM ; W:$D(IOF) @IOF W !,"********** ALL PCC VISITS BY PROVIDER DISCIPLINE PCC REPORT AA **********",! W !,"This report will print Year to Date PCC Visit Counts for the Facility",!,"and Fiscal Year that you select. The counts by month are for date of" W !,"service. This report will resemble, the AA report produced at the Data",!,"Center, BUT this report contains all PCC visits, not just those defined as APC",!,"visits.",! W !,"This report includes all PCC VISITS with the exception of the following:" W !?5,"- visits with service categories H-HOSPITALIZATION, I-IN HOSPITAL, E-EVENTS" W !?5,"- visits with Type C-CONTRACT or V-VA" W !?5,"- visits with no Primary Provider or POV" Q ; ; APCLASK APCLASK(APCLDFN,APCLCUML) ; IHS/OHPRD/TMJ -GET PATIENT OR COHORT ; [ 11/02/98 10:48 AM ] ;;3.0;IHS PCC REPORTS;**3**;FEB 05, 1997 ;CMI/TUCSON/LAB - patch 3 - 10/26/1998 Y2K fixes ;The above line will be changed to be nonparameter as of the ;next version of this package. All callers should enter this ;routine at entry point START1^APCLASK(,,,) G START2 ; START1(APCLDFN,APCLCUML) ;EP ; START2 ;PUBLISHED ENTRY POINT I 'APCLDFN W !,*7,"Report template entry not indicated!" H 2 Q I '$D(^APCLRPT(APCLDFN)) W !,*7,"Indicated patient/cohort report template entry does not exist!" H 2 Q I '$D(APCLCUML) S APCLCUML=0 I APCLCUML,'$D(^APCLRPT(APCLCUML)) W !,*7,"Indicated cumulative report entry does not exist!" H 2 Q I '$D(DTIME) D ^XBKVAR GETTIME S APCLSTP=0 D TIME G:APCLSTP X START K ^TMP("APCLPTS",$J) F D ASK Q:APCLSTP I '$D(^TMP("APCLPTS",$J))!(X["^") D CLEAN K APCLBDT,APCLEDT,APCLDATE,APCLFISC G GETTIME S APCLSTP=0 K DIR S DIR(0)="S^1:Print Both Individual and Cumulative Reports;2:Print Individual Reports Only;3:Print Cumulative Report Only;4:Create EPI INFO file",DIR("A")="Enter Print option",DIR("B")="1" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G START S APCLPREP=Y I APCLPREP=4 D FLAT Q:APCLSTP D TASK I $D(IO("Q")) K IO("Q") D QUE G AGIN I 'POP S APCLSTP=0 D ZTM AGIN D CLEAN S APCLSTP=0 G START X D EOJ Q ; TIME ; Get fiscal year or time frame S Y=DT D DD^%DT S APCLTDTE=Y S DIR(0)="SO^1:Fiscal Year;2:Date Range",DIR("A")="Indicate the desired time frame" D ^DIR K DIR I '$D(DTOUT),'$D(DIRUT),'$D(DIROUT),Y W ! D @Y I 1 E S APCLSTP=1 Q ; 1 ; Fiscal Year S DIR(0)="DA",DIR("A")="Enter report fiscal year: " D ^DIR K DIR I '$D(DTOUT),'$D(DIRUT),'$D(DIROUT) S APCLFISC=$S($E(Y)=2:19,1:20)_$E(Y,2,3) D . ;beginning Y2K CMI/TUCSON/LAB . ;I APCLFISC=2000 S APCLBDT=2991001,APCLEDT=2000930 ;Y2000 . ;E S APCLBDT=$E(Y,1,3)-1_1001,APCLEDT=$E(Y,1,3)_"0930" . S APCLBDT=$E(Y,1,3)-1_1001,APCLEDT=$E(Y,1,3)_"0930" ;Y2000 . ;end Y2K CMI/TUCSON/LAB . S Y=APCLBDT D DD^%DT S APCLBDT=Y . S (APCLED,Y)=APCLEDT D DD^%DT S APCLEDT=Y . S APCLDATE=";DURING "_APCLBDT_"-"_APCLEDT . S APCLFISC="Fiscal Year "_APCLFISC E S APCLSTP=1 X2 Q ; 2 ; Date Range ASKBD S %DT="AEX",%DT("A")="Enter beginning date: " D ^%DT G:X=U X3 S APCLBDT=Y I Y<0 G ASKBD ASKED S %DT="AEX",%DT("A")="Enter ending date: " D ^%DT G:X=U X3 S APCLEDT=Y I Y<0,X]"" G ASKED I APCLBDT>APCLEDT!(APCLEDT>DT) W !,"Beginning and ending dates must be prior to today, and beginning date",!,"must precede ending date.",! G ASKBD X3 I $G(X)=U!'$D(APCLBDT)!'$D(APCLEDT) S APCLSTP=1 E D . S Y=APCLBDT D DD^%DT S APCLBDT=Y . S (APCLED,Y)=APCLEDT D DD^%DT S APCLEDT=Y . S APCLDATE=";DURING "_APCLBDT_"-"_APCLEDT Q ; ASK ; Get patient name or cohort ; K APCLPT R:'$D(APCLPTS) !,"Enter patient or [search template name: ",X:DTIME R:$D(APCLPTS) !,"Enter ANOTHER patient or [search template name: ",X:DTIME ;R !,"Enter patient or [search template name: ",X:DTIME I "^"[X S APCLSTP=1 G X1 I $E(X)'="[" S APCLPT="" E S X=$E(X,2,99) I '$D(APCLPT) S DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001)" S DIC=$S($D(APCLPT):"^DPT(",1:"^DIBT("),DIC(0)="EQM" D ^DIC K DIC I Y=-1 G ASK I $D(APCLPT) S ^TMP("APCLPTS",$J,+Y)="",APCLPTS=1 E F APCLPD=0:0 S APCLPD=$O(^DIBT(+Y,1,APCLPD)) Q:'APCLPD S ^TMP("APCLPTS",$J,APCLPD)="" K APCLPT X1 Q ; ZTM ; - ENTRY POINT - for taskman U IO S (APCLSTP,APCLEPIN)=0 S APCLASK="" ; Lets ^APCLPRT know that it is called by this routine K ^TMP("APCL",$J),^TMP("APCLCUML",$J),^TMP("APCLEPI",$J) S APCLROOT="^TMP(""APCL"",$J)" F APCLPD=0:0 S APCLPD=$O(^TMP("APCLPTS",$J,APCLPD)) Q:'APCLPD!APCLSTP D K ^TMP("APCL",$J) .I $P(^APCLRPT(APCLDFN,0),U,3)]"" D @("^"_$P(^(0),U,3)) .I APCLPREP'=3,APCLPREP'=4 D ^APCLPRT(APCLDFN,APCLROOT,APCLPD) .I APCLPREP=4 D EPIREC I APCLPREP'=2,APCLPREP'=4,APCLCUML,$D(^APCLRPT(APCLCUML)),$D(^TMP("APCLCUML",$J)),'APCLSTP D:$P(^APCLRPT(APCLCUML,0),U,3)]"" @("^"_$P(^(0),U,3)) S APCLROOT="^TMP(""APCLCUML"",$J)" D ^APCLPRT(APCLCUML,APCLROOT) I APCLPREP=4 D WRITEF^APCLDM K ^TMP("APCLCUML",$J),^TMP("APCLPTS",$J),^TMP("APCLEPI",$J) I $D(ZTQUEUED) S ZTREQ="@" D EOJ I '$D(ZTQUEUED) D ^%ZISC Q ; TASK ; Task? K IOP,%ZIS S %ZIS="PQM" D ^%ZIS I POP S IO=IO(0) Q ; QUE K ZTSAVE,ZTSK NEW % F %="APCLSTP","APCLDMRG","APCLPREP","APCLPD","APCLPT","APCLBDT","APCLEDT","APCLDATE","APCLFISC","APCLTDTE","APCLDFN","APCLCUML","APCLFILE","APCLED","^TMP(""APCLPTS"",$J,","DUZ(" S ZTSAVE(%)="" S ZTRTN="ZTM^APCLASK",ZTDESC=$P(^APCLRPT(APCLDFN,0),U)_" REPORT",ZTIO=ION,ZTDTH="" S:$D(IOCPU) ZTCPU=IOCPU D ^%ZTLOAD D HOME^%ZIS K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZTCPU I $D(IOF) W @IOF E W ! Q ; EPIREC ;create epi info record in ^TMP("APCLEPI",$J,n) S X=$$REC^APCLDM(APCLPD,"DM AUDIT EPI INFO REC 1"),APCLEPIN=APCLEPIN+1,^TMP("APCLEPI",$J,APCLEPIN)=X S X=$$REC^APCLDM(APCLPD,"DM AUDIT EPI INFO REC 2"),APCLEPIN=APCLEPIN+1,^TMP("APCLEPI",$J,APCLEPIN)=X S X=$$REC^APCLDM(APCLPD,"DM AUDIT EPI INFO REC 3"),APCLEPIN=APCLEPIN+1,^TMP("APCLEPI",$J,APCLEPIN)=X Q FLAT ; S APCLFILE="" S DIR(0)="F^3:8",DIR("A")="Enter the name of the FILE to be Created (3-8 characters)" K DA D ^DIR K DIR I $D(DIRUT) S APCLSTP=1 Q I X'?1.8AN W !!,"Invalid format, must be letters and numbers",! G FLAT S APCLFILE=$$LOW^XLFSTR(Y)_".rec" W !!,"I am going to create a file called ",APCLFILE," which will reside in ",!,"the ",$S($P(^AUTTSITE(1,0),U,21)=1:"/usr/spool/uucppublic",1:"C:\EXPORT")," directory.",! W "Actually, the file will be placed in the same directory that the data export" W !,"globals are placed. See your site manager for assistance in finding the file",!,"after it is created. PLEASE jot down and remember the following file name:",!?15,"********** ",APCLFILE," **********",! W "It may be several hours (or overnight) before your report and flat file are ",!,"finished.",! W !,"The records that are generated and placed in file ",APCLFILE W !,"are in a format readable by EPI INFO. For a definition of the format",!,"please see your user manual.",! S DIR(0)="Y",DIR("A")="Is everything ok? Do you want to continue?",DIR("B")="Y" K DA D ^DIR K DIR I $D(DIRUT) S APCLSTP=1 Q I 'Y S APCLSTP=1 Q Q CLEAN ; K APCLPD,APCLPT,^TMP("APCLPTS",$J),APCLPREP,APCLPTS,APCLEPIN Q ; EOJ ; I IO'=IO(0) D ^%ZISC K APCLFISC,APCLPD,APCLPT,APCLDATE,APCLSTP,APCLDTE,APCLEDT,APCLBDT,APCLTDTE,APCLDFN,APCLROOT,^TMP("APCLPTS",$J),APCLASK,AUPNSEX,AUPNPAT,AUPNDAYS,AUPNSEX,AUPNDOD,AUPNDOB,APCLPREP,APCLEPIN,APCLED,APCLMAM,APCLED,APCLBD,APCLUED,ZTCPU K APCLHTKI,APCLRXC1 Q ; APCLDM8 APCLDM8 ; IHS/OHPRD/TMJ - PPD STUFF ; [ 06/02/97 3:45 PM ] ;;3.0;IHS PCC REPORTS;**1**;FEB 05, 1997 ;IHS/TUCSON/LAB - patch 1 - 05/27/97 fixed cumulative TB STATUS calculation modified subroutine TBTXST and PPDCODE ; ; START ; PPD ;EP S APCLX=APCLPD_"^LAST SKIN PPD" S APCLER=$$START1^APCLDF(APCLX,APCLY) I '$D(APCL(1)) S ^TMP("APCL",$J,20)="No recorded PPD" I $D(APCL(1)) S Y=$P(APCL(1),U) D DD^%DT S ^TMP("APCL",$J,20)=$S($P(^AUPNVSK(+$P(APCL(1),U,4),0),U,5)]"":$P(^(0),U,5)_"mm;",1:"")_$S($P(APCL(1),U,2)'="P":"NEGATIVE - "_Y,1:"POSITIVE - "_Y) TBTXST ;TB Treatment Status, 21 get last TB related health factor S %=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0)) I '% S ^TMP("APCL",$J,21)="TB Health Factor TAXONOMY MISSING!!" G PPDCODE ;IHS/TUCSON/LAB patch 1 - 05/27/97 - added this line I % D .S (X,Y)=0 F S X=$O(^AUPNHF("AA",APCLPD,X)) Q:X'=+X!(Y) I $D(^ATXAX(%,21,"B",X)) S Y=X .I Y S Y=$P(^AUTTHF(Y,0),U),^TMP("APCL",$J,21)=Y ;IHS/TUCSON/LAB - patch 1 - 05/27/97 modified this line ;I Y]"" S ^TMP("APCL",$J,21)=Y G TBCUML ;IHS/TUCSON/LAB - patch 1 - commented out this line and added line below I $D(^TMP("APCL",$J,21)) G TBCUML K APCL S APCLY="APCL(",APCLX=APCLPD_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S APCLER=$$START1^APCLDF(APCLX,APCLY) S ^TMP("APCL",$J,21)=$S($D(APCL(1)):$P(APCL(1),U,3),1:"TB Health Factor Not recorded") TBCUML I APCLCUML D .I ^TMP("APCL",$J,21)["Not recorded" S APCLGOT1=1,APCLSUB=94 D CUML^APCLDM1 F APCLSUB=90:1:93 S APCLGOT1=0 D CUML^APCLDM1 .I ^TMP("APCL",$J,21)["TB - TX COMPLETE" S APCLGOT1=1,APCLSUB=90 D CUML^APCLDM1 F APCLSUB=91:1:94 S APCLGOT1=0 D CUML^APCLDM1 .I ^TMP("APCL",$J,21)["TB - TX INCOMPLETE" S APCLGOT1=1,APCLSUB=91 D CUML^APCLDM1 F APCLSUB=90,92,93,94 S APCLGOT1=0 D CUML^APCLDM1 .I ^TMP("APCL",$J,21)["TB - TX UNKNOWN" S APCLGOT1=1,APCLSUB=93 D CUML^APCLDM1 F APCLSUB=90,91,92,94 S APCLGOT1=0 D CUML^APCLDM1 .I ^TMP("APCL",$J,21)["TB - TX UNTREATED" S APCLGOT1=1,APCLSUB=92 D CUML^APCLDM1 F APCLSUB=90,91,93,94 S APCLGOT1=0 D CUML^APCLDM1 PPDCODE ;PPD STATUS CODE S APCLJ="" ;IHS/TUCSON/LAB - patch 1 - added the 2 lines below I $G(^TMP("APCL",$J,21))="TB - TX COMPLETE" S APCLJ=1 G PPDCUML I $G(^TMP("APCL",$J,21))["TB - " S APCLJ=2 G PPDCUML I ^TMP("APCL",$J,20)["POSITIVE" D G PPDCUML .I $G(^TMP("APCL",$J,21))="TB - TX COMPLETE" S APCLJ=1 .S APCLJ=2 .Q I ^TMP("APCL",$J,20)["NEGATIVE" S APCLJ=5 D G PPDCUML .I ^TMP("APCL",$J,37)["not recorded" S APCLJ=5 Q .S X=^TMP("APCL",$J,37),%DT="" D ^%DT S APCLI=Y,X=$P(^TMP("APCL",$J,20),"- ",2),%DT="" D ^%DT S APCLJ=$S(Y>APCLI:3,1:4) .Q S APCLJ=6 PPDCUML ;cumulative PPD S ^TMP("APCL",$J,36)=$P($T(@APCLJ),";;",2)_" ("_APCLJ_")" Q:'APCLCUML S APCLI="70,71,72,73,74,75" F APCLX=1:1:6 S APCLSUB=$P(APCLI,",",APCLX),APCLGOT1=$S(APCLJ=APCLX:1,1:0) D CUML^APCLDM1 Q ; TBCODE(DFN) ; NEW APCLJ,APCLI S APCLJ="" ;return computed TB Status Code I ^TMP("APCL",$J,20)["POSITIVE" D Q APCLJ .I $G(^TMP("APCL",$J,21))="TB - TX COMPLETE" S APCLJ=1 .S APCLJ=2 .Q I ^TMP("APCL",$J,20)["NEGATIVE" S APCLJ=4 D Q APCLJ .I ^TMP("APCL",$J,37)["not recorded" S APCLJ=4 Q .S X=^TMP("APCL",$J,37),%DT="" D ^%DT S APCLI=Y,X=$P(^TMP("APCL",$J,20),"- ",2),%DT="" D ^%DT S X=$S(Y>APCLI:3,1:4) .Q S APCLJ=4 Q APCLJ ;; 1 ;;PPD +, treatment complete 2 ;;PPD +, not treated or unknown treatment 3 ;;PPD -, up-to-date (placed after dm dx) 4 ;;PPD -, before DM dx 5 ;;PPD -, DM dx date unknown 6 ;;PPD Status unknown APCLFY APCLFY ; IHS/OHPRD/TMJ - FISCAL YEAR process routine ; [ 11/02/98 10:49 AM ] ;;3.0;IHS PCC REPORTS;**3**;FEB 05, 1997 ; ;CMI/TUCSON/LAB - patch 3 - 10/26/1998 ; START ;beginning of routine K APCL I $D(^APCCCTRL(DUZ(2))),($P(^(DUZ(2),0),U,8)]"") D MONTH E S APCL("FY MONTH")=10 S Y=DT D DD^%DT S APCL("FY TODAY")=Y FYYEAR ;process FISCAL YEAR ;beginning of Y2k fix. CMI/TUCSON/LAB Commented out one line and modified one line to default a 4 digit yearand kill %DT which was left around and could cause trouble ;S %DT="AE",%DT("A")="Enter FISCAL YEAR: ",%DT("B")=$E(DT,2,3) D ^%DT K %DT K %DT S %DT="AE",%DT("A")="Enter FISCAL YEAR: ",%DT("B")=(1700+$E(DT,1,3)) D ^%DT K %DT ;Y2000 G:Y=-1 XIT ;S APCL("FY")=X ;S APCL("FY")=X ;Y2000 ;end Y2K CMI/TUCSON/LAB I $E(APCL("FY MONTH"),1)=1 S APCL("FY YEAR")=$E(Y,1,3),APCL("FY YEAR")=APCL("FY YEAR")-1 S:'$D(APCL("FY YEAR")) APCL("FY YEAR")=$E(Y,1,3) FYDATE ;process beginning DATE for fiscal year S APCL("FY BEG DATE")=APCL("FY YEAR")_APCL("FY MONTH")_"01" S Y=APCL("FY BEG DATE") X ^DD("DD") S APCL("FY PRINTABLE BDATE")=Y WORKDATE ;setup WORKING start day S X1=APCL("FY BEG DATE"),X2=-1 D C^%DTC S APCL("FY WORKING DT")=X_".9999" FYEND ;set up END date for fiscal year S APCL("FY YR ADD")=$E(APCL("FY WORKING DT"),1,3)+1 S APCL("FY END DATE")=APCL("FY YR ADD")_$E(APCL("FY WORKING DT"),4,7) S Y=APCL("FY END DATE") X ^DD("DD") S APCL("FY PRINTABLE EDATE")=Y XIT ;end of routine K %DT Q ;--------------------------------------------------------------------- MONTH ;setup MONTH for process S APCL("FY MONTH")=$P(^APCCCTRL(DUZ(2),0),U,8) S APCL("FY MONTH NAME")=$$EXTSET^XBFUNC(9001000,.08,APCL("FY MONTH")) S:$L(APCL("FY MONTH"))'=2 APCL("FY MONTH")=0_APCL("FY MONTH") Q FYENDDT ;set up END date for fiscal year S APCL("FY YR ADD")=$E(APCL("FY WORKING DT"),1,3)+1 S APCL("FY END DATE")=APCL("FY YR ADD")_$E(APCL("FY WORKING DT"),4,7) S Y=APCL("FY END DATE") X ^DD("DD") S APCL("FY PRINTABLE EDATE")=Y Q ENDDATE ;if FLAG=1 D:APCL("FYEND FLAG")=1 FYENDDT APCLOS APCLOS ; IHS/OHPRD/TMJ - PCC Operational Summary ; [ 11/02/98 10:50 AM ] ;;3.0;IHS PCC REPORTS;**3**;FEB 05, 1997 ; ;CMI/TUCSON/LAB 10/26/1998 PATCH 3 Y2K FIXES ; START ; I '$G(DUZ(2)) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",! Q W:$D(IOF) @IOF W !,"********** PCC OPERATIONS SUMMARY REPORT **********",! W !!,"This report displays data for a single month or for FY-to-Date for a specific",!,"facility or for the entire SU if all data for the SU is processed on this",!,"computer." W !!,"When selecting the period for which the report is to be run, consider whether",!,"or not all data has been entered for that period.",!! S APCLJOB=$J,APCLBTH=$H SELTYP K DIC S DIC=9001003.1,DIC("A")="Select operations summary type: ",DIC(0)="AEQM" D ^DIC I Y<0 G EOJ S APCLRPT=+Y SU S B=$P(^AUTTLOC(DUZ(2),0),U,5) I B S S=$P(^AUTTSU(B,0),U),DIC("A")="Please Identify your Service Unit: "_S_"//" S DIC="^AUTTSU(",DIC(0)="AEMQZ" W ! D ^DIC K DIC I X="^" G EOJ I X="" S (APCLSU,APCLSUF)=B G SUF G:Y=-1 SUF S APCLSU=+Y,APCLSUF=$P(^AUTTSU(APCLSU,0),U) SUF ; S APCLLOC="" D XTMP^APCLOSUT("APCLSU","PCC OPERATIONS SUMMARY") K APCLQUIT,^XTMP("APCLSU",APCLJOB,APCLBTH) K DIR S DIR(0)="S^O:ONE Particular Facility/Location;S:All Facilities within the "_$P(^AUTTSU(APCLSU,0),U)_" SERVICE UNIT;T:A TAXONOMY or selected set of Facilities" S DIR("A")="Enter a code indicating what FACILITIES/LOCATIONS are of interest",DIR("B")="O" K DA D ^DIR K DIR,DA G:$D(DIRUT) EOJ S APCLLOCT=Y D @APCLLOCT G:$D(APCLQUIT) SUF I '$D(^XTMP("APCLSU",APCLJOB,APCLBTH)) W !!,$C(7),$C(7),"No facilities selected.",! G SUF W !!!,"Only patients who have charts at the facilities you selected will be included",!,"in this report. Also, only visits to these locations will be counted in the ",!,"visit sections.",! MFY ;MONTH OR FYTODATE W !! S DIR(0)="SO^1:A Single Month;2:Fiscal Year",DIR("A")="Run report for" D ^DIR K DIR W !! G:$D(DIRUT) SUF S APCLMFY=Y G:Y=2 2 1 ; S %DT="AEP",%DT(0)="-NOW",%DT("A")="Enter the Month/Year: " D ^%DT I $D(DTOUT) G MFY I X="^" G MFY I Y=-1 D ERRM G 1 I $E(Y,6,7)'="00" D ERRM G 1 S APCLMON=Y S APCLFYB=$E(Y,1,5)_"01",APCLFYE=$E(Y,1,5)_"31" K %DT,Y,X G ZIS 2 ; S APCL("FYEND FLAG")=0 D ^APCLFY G:Y=-1 MFY ;beginning Y2K. CMI/TUCSON/LAB Modified this section of code to set dates appropriately. ;I $G(APCL("FY"))=$E(DT,2,3)&(DT'>APCL("FY END DATE")) W !!?6,"Current FISCAL Year date range: ",APCL("FY PRINTABLE BDATE")," - ",APCL("FY TODAY") I DTAPCL("FY END DATE")) %DT("B")=APCL("FY TODAY") I DT930:0,1:-365) D C^%DTC ZIS ; S Y=DT D DD^%DT S APCLDTP=Y S Y=APCLFYE D DD^%DT S APCLFYEY=Y W !!!,"THIS REPORT WILL SEARCH THE ENTIRE PATIENT FILE!",!!,"IT IS STRONGLY RECOMMENDED THAT YOU QUEUE THIS REPORT FOR A TIME WHEN THE",!,"SYSTEM IS NOT IN HEAVY USE!",! S XBRP="^APCLOSP",XBRC="^APCLOS1",XBRX="EOJ^APCLOS",XBNS="APCL" D ^XBDBQUE ; EOJ ;ENTRY POINT D EOJ^APCLOSUT Q O ; W ! S DIC("A")="Which Facility: ",DIC="^AUTTLOC(",DIC(0)="AEMQ" D ^DIC K DIC,DA I Y<0 S APCLQUIT=1 Q S ^XTMP("APCLSU",APCLJOB,APCLBTH,+Y)="" Q S ; W !!,"Gathering up all the facilities..." S X=0 F S X=$O(^AUTTLOC(X)) Q:X'=+X I $P(^AUTTLOC(X,0),U,5)=APCLSU S ^XTMP("APCLSU",APCLJOB,APCLBTH,X)="" Q T ;taxonomy - call qman interface K APCLLOC S X="ENCOUNTER LOCATION",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" S APCLQUIT=1 Q D ^AMQQGTX0(+Y,"APCLLOC(") I '$D(APCLLOC) S APCLQUIT=1 Q I $D(APCLLOC("*")) K APCLLOC,^XTMP("APCLSU",APCLJOB,APCLBTH) W !!,$C(7),$C(7),"ALL locations is NOT an option with this report",! G T S X="" F S X=$O(APCLLOC(X)) Q:X="" S ^XTMP("APCLSU",APCLJOB,APCLBTH,X)="" K APCLLOC Q ERRM W !,$C(7),$C(7),"Must be a valid Month/Year. Enter only a Month and a Year!",! Q APCLOS3 APCLOS3 ; IHS/OHPRD/TMJ - CHS PORTION OF OS ; [ 06/02/97 3:53 PM ] ;;3.0;IHS PCC REPORTS;**1**;FEB 05, 1997 ; ;IHS/TUCSON/LAB - modified routine to use B index on ACHSF to avoid ;errors - patch 1 - 06/02/97 ; CHS ; S APCLOS="APCLOS",APCLODAT=APCLFYB,APCLEDAT=APCLFYE D CHS0 S APCLOS="APCLOSP",APCLODAT=APCLPYB,APCLEDAT=APCLPYE D CHS0 K APCLODAT,APCLF,APCLN,APCLCHSR,APCLEDAT,APCLTOS,APCLPAY,APCLTOSE Q CHS0 S APCLF=0 F S APCLF=$O(^ACHSF("B",APCLF)) Q:APCLF'=+APCLF I $D(^XTMP("APCLSU",APCLJOB,APCLBTH,$P(^ACHSF(APCLF,0),U))) D CHS1 ;IHS/TUCSON/LAB - modified above to use B index patch 1 06/02/97 Q CHS1 ; S APCLN=0 F S APCLN=$O(^ACHSF(APCLF,"D",APCLN)) Q:APCLN'=+APCLN S APCLCHSR=^ACHSF(APCLF,"D",APCLN,0) D CHS2 Q CHS2 ; Q:$P(APCLCHSR,U,2)APCLEDAT I $E(APCLFY,2)'=$P(APCLCHSR,U,14) Q S APCLTOS=$P(APCLCHSR,U,4) S APCLPAY=$S($D(^ACHSF(APCLF,"D",APCLN,"PA")):$P(^ACHSF(APCLF,"D",APCLN,"PA"),U),1:"") S:APCLPAY="" APCLPAY=$P(APCLCHSR,U,9) S:APCLPAY="" APCLPAY=0 K ^UTILITY("DIQ1",$J) K DIQ,DIC,DA,DR ;S DIC=9002080,DR=100,DA=APCLF,DA(9002080.01)=APCLN,DR(9002080.01)=3,DIQ(0)="E" D EN^DIQ1 K DIC,DA,DR,DIQ S APCLTOSE=$S(APCLTOS=1:"43 - HOSPITALIZATION",APCLTOS=2:"57 - DENTAL",APCLTOS=3:"64 - NON-HOSPITAL SERVICE",1:"UNKNOWN") ;S APCLTOSE=^UTILITY("DIQ1",$J,9002080.01,APCLF,APCLN) S:APCLTOS="" APCLTOS=9999999999 S ^(APCLTOSE)=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"CHS",APCLTOS,APCLTOSE)):+^(APCLTOSE)+APCLPAY,1:APCLPAY) S ^(APCLTOSE)=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"CHSCOUNT",APCLTOS,APCLTOSE)):+^(APCLTOSE)+1,1:1) K ^UTILITY("DIQ1",$J) S ^("CHSTOTAL")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"CHSTOTAL")):+^("CHSTOTAL")+APCLPAY,1:APCLPAY) Q INPT ; S APCLNBCD=$O(^DIC(45.7,"CIHS","07","")),APCLNBC=0,APCLNBDY=0 S APCLOS="APCLOS",%="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,",APCLA=%_"""INPTPOV"",APCLPOV)",APCLC=%_"""INPTPOVC"""_")",APCLODAT=APCLFYB-.0001,APCLEDAT=APCLFYE D V S APCLOS="APCLOSP",%="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,",APCLA=%_"""INPTPOV"",APCLPOV)",APCLC=%_"INPTPOVC)",APCLODAT=APCLPYB-.0001,APCLEDAT=APCLPYE D V D ALOS K APCLA,APCLODAT,APCLC,APCLHREC,APCL1,APCL2,APCLVREC,APCLPOV,%,APCLEDAT,APCLLOS,APCLVDFN,APCLVINP,APCLVLOC Q ; V ; Run by visit date F S APCLODAT=$O(^AUPNVINP("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLEDAT) D V1 D SET Q V1 ; S APCLVINP="" F S APCLVINP=$O(^AUPNVINP("B",APCLODAT,APCLVINP)) Q:APCLVINP'=+APCLVINP I $D(^AUPNVINP(APCLVINP,0)) S APCLHREC=^(0) D PROC Q PROC ; S APCLVDFN=$P(APCLHREC,U,3) S APCLVREC=^AUPNVSIT(APCLVDFN,0) Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3))) ;LAB/OHPRD changed CV to V for VA S APCLVLOC=$P(APCLVREC,U,6) Q:'$D(^XTMP("APCLSU",APCLJOB,APCLBTH,APCLVLOC)) Q:'$D(^AUPNVPOV("AD",APCLVDFN)) Q:'$D(^AUPNVPRV("AD",APCLVDFN)) PROC1 S (APCL1,APCL2)=0 F S APCL2=$O(^AUPNVPOV("AD",APCLVDFN,APCL2)) Q:APCL2="" I $P(^AUPNVPOV(APCL2,0),U,12)="P" S APCL1=APCL1+1,APCLPOV=$P(^(0),U) Q:APCL1=0 Q:APCL1>1 I APCLNBCD]"",$P(APCLHREC,U,5)=APCLNBCD S APCLNBC=APCLNBC+1 D .S X1=$P(APCLODAT,"."),X2=$P((APCLVREC/1),".") D ^%DTC S APCLLOS=X S:APCLLOS=0 APCLLOS=1 S APCLNBDY=APCLNBDY+APCLLOS Q:$P(APCLHREC,U,5)=APCLNBCD S ^("DISCH")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"DISCH")):(+^("DISCH")+1),1:1) S X1=$P(APCLODAT,"."),X2=$P((APCLVREC/1),".") D ^%DTC S APCLLOS=X S:APCLLOS=0 APCLLOS=1 S ^("PATDAYS")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"PATDAYS")):+^("PATDAYS")+APCLLOS,1:APCLLOS) Q:APCLPOV="" Q:'$D(^ICD9(APCLPOV,0)) S X=APCLA ; I '$D(@X) S @X=0 S %=@X,%=%+1,@X=% Q ; SET F APCLPOV=0:0 S APCLPOV=$O(@APCLA) Q:'APCLPOV S %=^(APCLPOV) S ^XTMP(APCLOS,APCLJOB,APCLBTH,"INPTPOVC",9999999-%,APCLPOV)=% Q ALOS ; S APCLOS="APCLOS" D ALOS1 S APCLOS="APCLOSP" D ALOS1 Q ALOS1 ; Q:'$D(^XTMP(APCLOS,APCLJOB,APCLBTH,"DISCH")) S ^XTMP(APCLOS,APCLJOB,APCLBTH,"ALOS")=(^XTMP(APCLOS,APCLJOB,APCLBTH,"PATDAYS")/^XTMP(APCLOS,APCLJOB,APCLBTH,"DISCH")) S ^XTMP(APCLOS,APCLJOB,APCLBTH,"ALOS")=$J(^XTMP(APCLOS,APCLJOB,APCLBTH,"ALOS"),1,1) Q APCLPRT APCLPRT(APCLDFN,APCLROOT,APCLPD) ; IHS/OHPRD/TMJ - PRINTS REPORTS USING REPORT TEMPLATE FILE ; [ 11/02/98 10:51 AM ] ;;3.0;IHS PCC REPORTS;**3**;FEB 05, 1997 ; ;CMI/TUCSON/LAB - patch 3 - 10/26/1998 - Y2K fixes ; ; - ENTRY POINT - I '$D(APCLROOT) W !,*7,"Global root not indicated!" Q I '$D(ZTQUEUED),$P(IOST,"-")="C" S APCLBRK="" W @IOF S APCLENDR=$E(APCLROOT,$L(APCLROOT)) I "(,"[APCLENDR S APCLROOT=$E(APCLROOT,1,($L(APCLROOT)-1)) S APCLENDR=$E(APCLROOT,$L(APCLROOT)) I APCLENDR'=")",APCLROOT["(" S APCLROOT=APCLROOT_")" S (APCLOOP,APCLCNT,APCLSTP)=0 F S APCLOOP=$O(^APCLRPT(APCLDFN,21,APCLOOP)) Q:'APCLOOP!APCLSTP S APCLL=0 S APCLLINE=^(APCLOOP,0) D D APCLWRTE . F I=1:1 Q:$P(APCLLINE,"|",2,99)="" S APCLN=+$P(APCLLINE,"|",2),APCLTMP=$P(APCLLINE,"|") S APCLV=$S($D(@APCLROOT@(APCLN)):@APCLROOT@(APCLN),1:"") D:APCLV="" CODE D:APCLV]""&($P($G(^APCLRPT(APCLDFN,31,APCLN,0)),U,2)="p") PCT D K APCLCODE .. I ($L(APCLTMP)+$L(APCLV))>$S($D(APCLCODE):250,1:IOM) S APCLL=APCLL+1 S APCLWRTE(APCLL)=APCLTMP S APCLLINE=APCLV_$P(APCLLINE,"|",3,999) Q .. S APCLTMP=APCLTMP_APCLV .. I ($L(APCLTMP)+$L($P(APCLLINE,"|",3,999)))>IOM S APCLL=APCLL+1 S APCLWRTE(APCLL)=APCLTMP S APCLLINE=$P(APCLLINE,"|",3,999) Q .. S APCLLINE=APCLTMP_$P(APCLLINE,"|",3,999) . S APCLL=APCLL+1 S APCLWRTE(APCLL)=APCLLINE I $D(APCLBRK),'APCLSTP D PAGE I 1 E W @IOF K APCLOOP,APCLBRK,APCLCNT,APCLI,APCLTMP,APCLL,APCLLINE,APCLN,APCLV,APCLWRTE,APCLX,APCLENDR I '$D(APCLASK) K APCLSTP Q ; CODE ; Get date or value from data fetcher NEW APCLDIS,APCLI,APCLSTP K APCLER I $G(APCLPD),$G(^APCLRPT(APCLDFN,31,APCLN,21))]"" S APCLCODE=^(21) D . I APCLCODE["*" S APCLV="Script error - '*' entered as a value!" Q . I $G(APCLDATE)]"",$P(APCLCODE,";",2)]"" S APCLV="Script error - date information entered!" Q . S APCLDIS=$S($P(APCLCODE," ")="DATE":"DATE",$P(APCLCODE," ")="VALUE"!("PATPT"[$P(APCLCODE," ")):"VALUE",1:"BOTH") . I $E($P(APCLCODE," "),1,3)["PAT"!($E($P(APCLCODE," "),1,2)["PT") . E I APCLDIS="DATE"!(APCLDIS="VALUE") S APCLCODE=$P(APCLCODE," ",2,99) . I $E($P(APCLCODE," "),1,3)'="PAT",$E($P(APCLCODE," "),1,2)'="PT" S APCLCODE=APCLCODE_$G(APCLDATE) . S APCLX=APCLPD_"^"_APCLCODE,APCLY="APCLDF(" S APCLER=$$START1^APCLDF(APCLX,APCLY) K APCLX,APCLY . I APCLER S APCLV="Data Retrieval Error!" K APCLER Q . K APCLER . I '$D(APCLDF) S APCLV="None Found" K APCLDF Q . I APCLDIS="BOTH"!(APCLDIS="DATE") F APCLI=1:1 Q:'$D(APCLDF(APCLI)) D Q:$G(APCLSTP) D SET .. I ($L(APCLV)+6)>246 S APCLSTP=1,APCLV=APCLV_" ...etc." . I APCLDIS'="VALUE" K APCLDF Q . F APCLI=1:1 Q:'$D(APCLDF(APCLI)) D Q:$G(APCLSTP) S APCLV=$S(APCLI>1:APCLV_", ",1:$G(APCLV))_$P(APCLDF(APCLI),U,2) .. I ($L(APCLV)+6)>246 S APCLSTP=1,APCLV=APCLV_" ...etc." . K APCLDF,APCLPCE Q ; SET ; Set Value and or Date from PCC SCRIPT ;beginning Y2K fix. Modified line to use a 4 digit year rather than a 2 digit year. Not sure is this was necessary but it will work either way. ;S Y=$P(APCLDF(APCLI),U),Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) S APCLV=$S(APCLI>1:APCLV_", ",1:$G(APCLV))_$S(APCLDIS="BOTH":$P(APCLDF(APCLI),U,2)_" - "_Y,1:Y) S Y=$P(APCLDF(APCLI),U),Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3)) S APCLV=$S(APCLI>1:APCLV_", ",1:$G(APCLV))_$S(APCLDIS="BOTH":$P(APCLDF(APCLI),U,2)_" - "_Y,1:Y) ;Y2000 ;end Y2K fix Q ; APCLWRTE ; Write line I APCLWRTE(1)="@",$D(APCLBRK) D PAGE G X1 I APCLWRTE(1)="@" W @IOF S APCLCNT=0 G X1 F APCLX=1:1:APCLL Q:APCLSTP W !,APCLWRTE(APCLX) S APCLCNT=APCLCNT+1 I $D(APCLBRK),(IOSL-3)APCLED) D V1 S C=0 F S C=$O(^XTMP("APCLT1",APCLJOB,APCLBTH,"MODE",C)) Q:C'=+C D . S P=0 F S P=$O(^XTMP("APCLT1",APCLJOB,APCLBTH,"MODE",C,P)) Q:P'=+P D .. S S=0 F S S=$O(^XTMP("APCLT1",APCLJOB,APCLBTH,"MODE",C,P,S)) Q:S'=+S S X=^XTMP("APCLT1",APCLJOB,APCLBTH,"MODE",C,P,S),^XTMP("APCLT1",APCLJOB,APCLBTH,"SET",C,P,9999999-X)=S .. Q . Q ; END ; S APCLET=$H Q V1 ; S APCLVIEN="" F S APCLVIEN=$O(^AUPNVSIT("B",APCLODAT,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN I $D(^AUPNVSIT(APCLVIEN,0)),$P(^(0),U,9),'$P(^(0),U,12) S APCLVREC=^(0) D PROC1 Q PROC1 ; Q:'$P(APCLVREC,U,8) ;no clinic Q:'$D(^AUPNVPRV("AD",APCLVIEN)) ;no provider S APCLPP=$$PRIMPROV^APCLV(APCLVIEN,"I") Q:'APCLPP ;no primary provider returned S APCLCLN=$P(APCLVREC,U,8) I $D(APCLCLNT),'$D(APCLCLNT(APCLCLN)) Q ;IHS/TUCSON/LAB - added this next line for patch 1 05/01/97 I $D(APCLAPWI),$P(APCLVREC,U,16)'=APCLAPWI Q S APCLAPPT=$P(APCLVREC,U,26) S APCLCI=$P(APCLVREC,U) S APCLPPS="",X=0 F S X=$O(^AUPNVPRV("AD",APCLVIEN,X)) Q:X'=+X I $P(^AUPNVPRV(X,0),U,4)="P",APCLPP=$P(^(0),U),$P($G(^AUPNVPRV(X,12)),U)]"" S APCLPPS=$P(^AUPNVPRV(X,12),U) S $P(^(APCLPP),U)=$S($D(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLPP)):$P(^(APCLPP),U)+1,1:1) S $P(^(APCLCLN),U)=$S($D(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN)):$P(^(APCLCLN),U)+1,1:1) Q:APCLAPPT="" Q:APCLCI="" Q:APCLPPS="" Q:$P(APCLPPS,".",2)="" ;Q:APCLPPSAPCLCI:APCLAPPT,1:APCLCI) S APCLSEC=$S(APCLPPS14400 S ^XTMP("APCLT1",APCLJOB,APCLBTH,"OUTLIERS",APCLVIEN)=$$FMTE^XLFDT($P(APCLVREC,U),"2E")_"^"_$P(^DPT($P(APCLVREC,U,5),0),U)_"^"_$$FMTE^XLFDT($P(APCLVREC,U,26),"2E")_"^"_$$FMTE^XLFDT(APCLPPS,"2E") Q I APCLSEC<-14400 S ^XTMP("APCLT1",APCLJOB,APCLBTH,"OUTLIERS",APCLVIEN)=$$FMTE^XLFDT($P(APCLVREC,U),"2E")_"^"_$P(^DPT($P(APCLVREC,U,5),0),U)_"^"_$$FMTE^XLFDT($P(APCLVREC,U,26),"2E")_"^"_$$FMTE^XLFDT(APCLPPS,"2E") Q S $P(^(APCLPP),U,2)=$S($D(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLPP)):$P(^(APCLPP),U,2)+1,1:1) S $P(^(APCLCLN),U,2)=$S($D(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN)):$P(^(APCLCLN),U,2)+1,1:1) SET S $P(^(APCLPP),U,3)=$S($D(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLPP)):$P(^(APCLPP),U,3)+APCLSEC,1:APCLSEC) S $P(^(APCLCLN),U,3)=$S($D(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN)):$P(^(APCLCLN),U,3)+APCLSEC,1:APCLSEC) S:$P(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLPP),U,4)="" $P(^(APCLPP),U,4)=APCLSEC I $P(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLPP),U,4)>APCLSEC S $P(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLPP),U,4)=APCLSEC S:$P(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN),U,4)="" $P(^(APCLCLN),U,4)=APCLSEC I $P(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN),U,4)>APCLSEC S $P(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN),U,4)=APCLSEC I $P(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLPP),U,5)300 S $P(^(APCLPP),U,7)=$S($D(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLPP)):$P(^(APCLPP),U,7)+1,1:1) I X>300 S $P(^(APCLCLN),U,7)=$S($D(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN)):$P(^(APCLCLN),U,7)+1,1:1) S $P(^(APCLSEC),U)=$S($D(^XTMP("APCLT1",APCLJOB,APCLBTH,"MODEP",APCLCLN,APCLPP,APCLSEC)):$P(^(APCLSEC),U)+1,1:1) S $P(^(APCLSEC),U)=$S($D(^XTMP("APCLT1",APCLJOB,APCLBTH,"MODEC",APCLCLN,APCLSEC)):$P(^(APCLSEC),U)+1,1:1) Q ; ; ; ; APCLT1P APCLT1P ; IHS/OHPRD/TMJ - print apc report ; [ 06/02/97 3:47 PM ] ;;3.0;IHS PCC REPORTS;**1**;FEB 05, 1997 ;IHS/TUCSON/LAB - added a header line to display appt/wi header 05/01/97 START ; S %DT="",X="T" D ^%DT S DT=Y D DD^%DT S APCLDT=Y S Y=APCLBD D DD^%DT S APCLBDD=Y S Y=APCLED D DD^%DT S APCLEDD=Y S (APCLTOT,APCLPG)=0 D HEAD S APCLCLN=0 K APCLQUIT F S APCLCLN=$O(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN)) Q:APCLCLN=""!($D(APCLQUIT)) D P G:$D(APCLQUIT) DONE I $D(^XTMP("APCLT1",APCLJOB,APCLBTH,"OUTLIERS")) S APCLOUT=1 D HEAD S APCLX=0 F S APCLX=$O(^XTMP("APCLT1",APCLJOB,APCLBTH,"OUTLIERS",APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT)) D .I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT) .S X=^XTMP("APCLT1",APCLJOB,APCLBTH,"OUTLIERS",APCLX) .W !,$P(X,U),?16,$P(X,U,2),?47,$P(X,U,3),?62,$P(X,U,4) .Q DONE ; D DONE^APCLOSUT K ^XTMP("APCLT1",APCLJOB,APCLBTH),APCLOUT Q P ; I $Y>(IOSL-5) D HEAD Q:$D(APCLQUIT) W !!,$P(^DIC(40.7,APCLCLN,0),U),?24,$J($P(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN),U),6),?32,$J($P(^(APCLCLN),U,2),6) S T=$P(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN),U,3),V=$P(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN),U,2),M=$S(V:T/V/60,1:".") W ?39,$J(M,6,1) W:$P(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN),U,4) ?46,$J($P(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN),U,4)/60,6,1) W:$P(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN),U,5) ?53,$J($P(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN),U,5)/60,6,1) W ?63,$J($P(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN),U,6),6),?71,$J($P(^XTMP("APCLT1",APCLJOB,APCLBTH,"TOTAL",APCLCLN),U,7),6) ;WRITE PROVIDER INFORMATION S APCLX=0 F S APCLX=$O(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLX)) Q:APCLX'=+APCLX!$D(APCLQUIT) D .I $Y>(IOSL-5) D HEAD Q:$D(APCLQUIT) .W !?3,$E($S($P(^AUTTSITE(1,0),U,22):$P(^VA(200,APCLX,0),U),1:$P(^DIC(16,APCLX,0),U)),1,20),?24,$J($P(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLX),U),6),?32,$J($P(^(APCLX),U,2),6) .S T=$P(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLX),U,3),V=$P(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLX),U,2),M=$S(V:T/V/60,1:".") .W ?39,$J(M,6,1) .W:$P(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLX),U,4) ?46,$J($P(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLX),U,4)/60,6,1) .W:$P(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLX),U,5) ?53,$J($P(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLX),U,5)/60,6,1) .W ?63,$J($P(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLX),U,6),6),?71,$J($P(^XTMP("APCLT1",APCLJOB,APCLBTH,"IND",APCLCLN,APCLX),U,7),6) .Q Q HEAD I 'APCLPG G HEAD1 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQUIT="" Q HEAD1 ; W:$D(IOF) @IOF S APCLPG=APCLPG+1 W !,$TR($J("",79)," ","*"),! W "*",?3,$P(^DIC(4,DUZ(2),0),U),?58,APCLDT,?68,"Page ",APCLPG,?76,"*",! W "*",?78,"*",! W "*",?22,"WAITING TIMES BY CLINIC AND PROVIDER",?78,"*",! S APCLLOCT=$P(^DIC(4,DUZ(2),0),U) S APCLLENG=21+$L(APCLLOCT) W "*",?((80-APCLLENG)/2),"LOCATION OF VISITS: ",APCLLOCT,?78,"*",! W "*",?18,"REPORT DATE: ",APCLBDD," TO ",APCLEDD,?78,"*",! W ?21,"Report includes ",$S(APCLAPWI="A":"APPOINTMENTS",1:"WALK INS")," only.",! ;IHS/TUCSON/LAB - patch 1 05/01/97 W $TR($J("",79)," ","*"),!! I $G(APCLOUT) W ?10,"VISITS NOT COUNTED BECAUSE OF >240 MINUTE WAIT TIMES",!,"ARRIVAL TIME",?16,"PATIENT NAME",?47,"APPT TIME",?62,"PROV SEEN" Q W !,"CLINIC",?24,"TOTAL",?32,"# VSTS",?41,"AVG",?48,"MIN",?55,"MAX",?61," #",?69," #",! W ?24,"VISITS",?34,"USED",?41,"WAIT",?48,"WAIT",?55,"WAIT",?64,"EARLY",?72,"LATE",! S X="",$P(X,"-",80)="" W X,! Q APCLV APCLV ; IHS/OHPRD/TMJ - visit data ; [ 06/02/97 3:48 PM ] ;;3.0;IHS PCC REPORTS;**1**;FEB 05, 1997 ;IHS/TUCSON/LAB - added G parameter to provider call ; ; COMM(V,F) ;PEP ; given V as visit ien, COMMUNITY - STATE,COUNTY,COMMUNITY codes of patient ;F="E":name of community, F="I":internal ien of community, F="C":stctycomm code G COMM^APCLV1 ; PCHART(P,L) ;PEP - returns chart at facility L ;FOR FORMAT SEE CHART G PCHART^APCLV1 CHART(V) ;PEP - returns ASUFAC_HRN ( 12 digits, HRN is left zero filled) ;V = visit ien, returns asufac_hrn for this visit ;if chart exists at Loc. of encounter it is returned ;if not, then chart at DUZ(2) is returned ;if none, then null returned G CHART^APCLV1 ; LOCENC(V,F) ;PEP - given visit ien V, return loc. of encounter in format F ;F="E":name of location , F="I":ien of location, F="C":asufac G LOCENC^APCLV1 ; VD(V,F) ;PEP - given visit ien in V, return date of visit in internal or external format ;F="I":internal fileman format, F="S":external slash date, F="E":external full (JAN 01, 1995) ; G VD^APCLV1 VDTM(V,F) ;PEP - given visit ien in V, return visit date and time in F format ;F="S":01/01/98 3:15pm, F="E":JAN 01, 1998 3:15PM, F="I":fileman internal format G VDTM^APCLV1 ; TIME(V,F) ;PEP - given visit ien in V, returns visit time of day i n format F ;F="E": form is 11:15 F="I" form is 1115 (fileman format), F="P" form in am/pm 11:15am G TIME^APCLV1 ; DOW(V,F) ;PEP - given V, visit ien and F, format returns DOW of visit ;in F="E":Monday, F="I":1 G DOW^APCLV1 ; TYPE(V,F) ;PEP - given V, visit ien and F, format, returns type of visit ;F="I":internal set, F="E":external set G TYPE^APCLV1 ; SC(V,F) ;PEP - given V=visit ien and F=format, returns service category of visit ;F="I":internal set, F="E":external set G SC^APCLV1 CLINIC(V,F) ;PEP - given V is visit ien, F is format, returns clinic on visit ;F="E":clinic name, F="C":clinic code, F="I":internal ien of clinic G CLINIC^APCLV1 ; EM(V,F) ;PEP - given V, visit ien and F, format, returns eval&man code of visit ;F="I":internal ien of cpt code, F="E":des of cpt code, F="C":cpt code G EM^APCLV1 ; LS(V,F) ;PEP - given V, visit ien and F, format, returns level of servie of visit ;F="I":internal set, F="E":external set G LS^APCLV1 ; ADMSERV(V,F) ;PEP - return admitting service in Code, internal or external form G ADMSERV^APCLV1 DSCHSERV(V,F) ;PEP - return discharge service in format F G DSCHSERV^APCLV1 NLAB(V) ;PEP - returns # of labs on the visit V G NLAB^APCLV1 ADMTYPE(V,F) ;PEP - return admission type i format F ;I = internal format ;E = long name of the type ;C = coded value G ADMTYPE^APCLV1 DSCHTYPE(V,F) ;PEP - return discharge type in format F ;I - internal format ;E - external name ;C - coded value G DSCHTYPE^APCLV1 G NLAB^APCLV1 NRX(V) ;PEP - returns # of rxs on visit V G NRX^APCLV1 ; PRIMPROV(V,F) ;PEP - returns primary provider on that visit in F format ;F is defined as: ;I - returns ien of provider in file 200 or 6 ;T - returns provider' initials ;A - returns internal set of affiliation (e.g. 1) ;B - returns external of affiliation (e.g. IHS) ;C - returns provider's code ;D - returns provider's discipline code (E.G. 01) ;E - returns provider's discipline in external format (PHYSICIAN) ;F - returns ien of provider's discipline (22) ;N - returns provider's name ;O - returns provider's affl_disc (e.g. 101 for IHS nurse) ;P - returns provider's affl_disc_code (e.g. 101LAB for nurse Lori Ann Butcher ;G - returns the event date&time for this provider G PRIMPROV^APCLV06 ; SECPROV(V,F,N) ;PEP - returns secondary provider N in format F ;see primPROV for format definitions, N is the 1-N secondary providers, if you want an array of all secondary providers user SECPROVS PEP. G SECPROV^APCLV06 ; PRIMPOV(V,F) ;PEP - returns primary pov on visit V in format F ;F is defined as ;I - ien of ICD9 code ;E - external of ICD9 (text) ;C - icd9 code ;A - APC recode ;D - cause of dx ;J - cause of injury ;P - place of injury ;N - provider narrative external text G PRIMPOV^APCLV07 ; SECPOV(V,F,N) ;PEP - returns secondary pov N in format F for visit V ;see primpov for definitions of F G SECPOV^APCLV07 ; PROC(V,F,N) ;PEP - returns procedure N in format F for visit V ;F is defined as ;I -ien of icd9 code (.01) ;E - external of icd code ;C- icd code ;P - CPT CODE ;T - CPT INTERNAL IEN ;D - date of proc/int fm format ;G - date of proc/ext format ;F - INFECTION Y/N ;R - PROV AFFL_DISC ;X - DX DONE FOR - N ;N - provider narrative G PROC^APCLV08 IMM(V,F,N) ;PEP - returns immunization done on visit V in format F number N ;F is defined as ;I - ien of immunization entry ;C - immunization code ;E - immunization name ;S - series G IMM^APCLV11 DENT(V,F,N) ;PEP - returns dental ;F is defined as ;I - ien of dental entry ;C - ada code ;E - ada name ;S - series G DENT^APCLV05 DSCHDATE(V,F) ;PEP - return discharge date in F format ;F="I":internal fileman format, F="S":external slash date, F="E":external full (JAN 01, 1995) ; G DSCHDATE^APCLV1 CONSULTS(V) ;PEP - return # of consults G CONSULTS^APCLV1 ATTPHY(V,F) ;PEP - return attending physician G ATTPHY^APCLV06 LOS(V) ;PEP - return length of stay G LOS^APCLV1 FACTX(V,F) ;PEP - return facility transferred to G FACTX^APCLV1 MIDWIFE(V) ;PEP - return midwifery code G MIDWIFE^APCLV06 ACTTIME(V) ;PEP - return activity time G ACTTIME^APCLV1 TRAVTIME(V) ;PEP - return travel time G TRAVTIME^APCLV1 CHSCOST(V) ;PEP - return CHS total cost G CHSCOST^APCLV1 PATIENT(V,F) ;PEP - return patient G PATIENT^APCLV1 DLM(V,F) ;PEP - return date last modified G DLM^APCLV1 DVEX(V,F) ;PEP - return date visit exported G DVEX^APCLV1 CODT(V,F) ;PEP - return check out date&time G CODT^APCLV1 APDT(V,F) ;PEP - return appt date&time from visit G APDT^APCLV1 APWI(V,F) ;PEP - return walk-in/appt G APWI^APCLV1 OUTSL(V) ;PEP - returns outside location G OUTSL^APCLV1 ;see programmer for a copy of documentation ADMDX(V,F) ;PEP - return admitting dx G ADMDX^APCLV07 PCCVF(V,T,F,A) ;PEP return v file information I $G(T)="" Q 1 ;no type of data defined I '$G(V) Q 3 ;no visit ien passed I $G(F)="" Q 2 ;no format defined I '$D(^AUPNVSIT(V)) Q 4 NEW APCLTYPE,X,APCLPROG S APCLTYPE="" F I=1:1 S X=$T(TVAL+I) Q:X=""!(APCLTYPE]"") I $P(X,";;",2)=T S APCLTYPE=$P(X,";;",2),APCLPROG=$P(X,";;",3) I APCLTYPE="" Q 5 ;not valid type K APCLV D @APCLPROG Q "" TVAL ; ;;MEASUREMENT;;MEAS^APCLV01;;9000010.01 ;;PROVIDER;;PROV^APCLV06;;9000010.06 ;;POV;;POV^APCLV07;;9000010.07 APCLV06 APCLV06 ; IHS/OHPRD/TMJ - provider functions ; [ 06/02/97 3:48 PM ] ;;3.0;IHS PCC REPORTS;**1**;FEB 05, 1997 ; ;IHS/TUCSON/LAB - add parameter to pass back event date&time on provider entry 05/19/97 patch 1 PRIMPROV ;EP - primary provider in many different formats I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW %,Y,P,Z ;IHS/TUCSON/LAB - added ,Z patch 1 5/19/97 S P="",Y=0 F S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y I $P(^AUPNVPRV(Y,0),U,4)="P" S P=$P(^AUPNVPRV(Y,0),U),Z=Y ;IHS/TUCSON/LAB - added ,Z=Y patch 1 05/19/97 I 'P Q P I $P(^AUTTSITE(1,0),U,22),'$D(^VA(200,P)) Q -1 I '$P(^AUTTSITE(1,0),U,22),'$D(^DIC(6,P)) Q -1 I $G(F)="" S F="N" S %="" D @F Q % ; SECPROV ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 I '$G(N) Q -1 NEW %,Y,P,Z ;IHS/TUCSON/LAB - PATCH 1 S P="",(C,Y)=0 F S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y I $P(^AUPNVPRV(Y,0),U,4)'="P" S C=C+1 I C=N S P=$P(^AUPNVPRV(Y,0),U),Z=Y ;IHS/TUCSON/LAB - patch 1 I 'P Q P I $P(^AUTTSITE(1,0),U,22),'$D(^VA(200,P)) Q -1 I '$P(^AUTTSITE(1,0),U,22),'$D(^DIC(6,P)) Q -1 I $G(F)="" S F="N" S %="" D @F Q % ; PROV ;EP NEW Z,C,%,S S (C,Y)=0 F S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y S C=C+1 S APCLV(C)="",P=$P(^AUPNVPRV(Y,0),U) D .I F=99 D Q ..F I=1:1 S S=$T(@I) Q:S="" S %="" D @I S $P(APCLV(C),U,I)=% .I F[";" D Q ..F J=1:1 S I=$P(F,";",J) Q:I="" I I'=99 S %="" D @I S $P(APCLV(C),U,J)=% .S %="",I=F D @I S $P(APCLV(C),U)=% .Q Q I ;EP S %=P Q T ;EP S %=$S($P(^AUTTSITE(1,0),U,22):$P($G(^VA(200,P,1)),U,2),1:$P(^DIC(6,P,0),U,2)) Q A ;EP S %=$S($P(^AUTTSITE(1,0),U,22):$P($G(^VA(200,P,9999999)),U),1:$P($G(^DIC(6,P,9999999)),U)) Q B ;EP S %=$S($P(^AUTTSITE(1,0),U,22):$P($G(^VA(200,P,9999999)),U),1:$P($G(^DIC(6,P,9999999)),U)) Q:%="" S %=$$EXTSET^XBFUNC(200,9999999.01,%) Q D ;EP D F Q:%="" S %=$P($G(^DIC(7,%,9999999)),U) Q ; E ;EP S %=$$VAL^XBDIQ1($S($P(^AUTTSITE(1,0),U,22):200,1:6),P,$S($P(^AUTTSITE(1,0),U,22):53.5,1:2)) Q F ;EP S %=$$VALI^XBDIQ1($S($P(^AUTTSITE(1,0),U,22):200,1:6),P,$S($P(^AUTTSITE(1,0),U,22):53.5,1:2)) Q C ;EP S %=$S($P(^AUTTSITE(1,0),U,22):$P($G(^VA(200,P,9999999)),U,2),1:$P($G(^DIC(6,P,9999999)),U,2)) Q N ;EP S %=$S($P(^AUTTSITE(1,0),U,22):$P($G(^VA(200,P,0)),U),1:$P($G(^DIC(16,P,0)),U)) Q O ;EP NEW A D A Q:%="" S A=%,%="" D D Q:%="" S %=A_% Q P ;EP NEW A D A Q:%="" S A=% NEW D D D Q:%="" S D=%,%="" D C Q:%="" S %=A_D_% Q G ;EP - event date&time IHS/TUCSON/LAB - added this subroutine patch 1 05/19/97 S %=$P($G(^AUPNVPRV(Z,12)),U) Q ; 1 ; S %=$$VD^APCLV($P(^AUPNVPRV(Y,0),U,3),"I") Q 2 ; S %=$$VD^APCLV($P(^AUPNVPRV(Y,0),U,3),"S") Q 3 ; S %=$P(^AUPNVPRV(Y,0),U,2) Q 4 ; S %=$$PATIENT^APCLV($P(^AUPNVPRV(Y,0),U,3),"E") Q 5 ; S %=$P(^AUPNVPRV(Y,0),U) Q 6 D T Q 7 D A Q 8 D B Q 9 D C Q 10 D D Q 11 D E Q 12 D F Q 13 D N Q 14 D O Q 15 D P Q 16 S %=$P(^AUPNVPRV(Y,0),U,4) Q 17 S %=$$VAL^XBDIQ1(9000010.06,Y,.04) Q 18 S %=$$VALI^XBDIQ1(9000010.06,Y,.05) Q 19 S %=$$VAL^XBDIQ1(9000010.06,Y,.05) Q 20 S %=$$VAL^XBDIQ1(9000010.06,Y,1201) Q ATTPHY ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW %,Y,P S P="",(C,Y)=0 F S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y I $P(^AUPNVPRV(Y,0),U,5)="A" S P=$P(^AUPNVPRV(Y,0),U) I 'P Q P I $P(^AUTTSITE(1,0),U,22),'$D(^VA(200,P)) Q -1 I '$P(^AUTTSITE(1,0),U,22),'$D(^DIC(6,P)) Q -1 I $G(F)="" S F="N" S %="" D @F Q % ; MIDWIFE ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 I $P(^AUPNVSIT(V,0),U,7)'="H" Q "" NEW %,Y,P S P="",(C,Y)=0 F S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y S P=$P(^AUPNVPRV(Y,0),U) I 'P Q P I $P(^AUTTSITE(1,0),U,22),'$D(^VA(200,P)) Q -1 I '$P(^AUTTSITE(1,0),U,22),'$D(^DIC(6,P)) Q -1 S %="" D D Q $S(%=17:1,1:"") ; ;return a 1 if one of the providers is a midwife (ihs code=17) APCLV07 APCLV07 ; IHS/OHPRD/TMJ - provider functions ; [ 06/02/97 3:48 PM ] ;;3.0;IHS PCC REPORTS;**1**;FEB 05, 1997 ; ;IHS/TUCSON/LAB - patch 1 05/19/97 - fixed setting of array PRIMPOV ;EP - primary provider in many different formats I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW %,Y,P,C,Z S (Z,P)="",(Y,C)=0 I $P(^AUPNVSIT(V,0),U,7)="H" F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y I $P(^AUPNVPOV(Y,0),U,12)="P" S P=$P(^AUPNVPOV(Y,0),U),Z=Y I $P(^AUPNVSIT(V,0),U,7)'="H" S Y=$O(^AUPNVPOV("AD",V,0)) I Y S P=$P(^AUPNVPOV(Y,0),U),Z=Y I 'P Q P I '$D(^ICD9(P)) Q -1 I $G(F)="" S F="C" S %="" D @F Q % ; SECPOV ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 I '$G(N) Q -1 NEW %,Y,P,C,Z S (Z,P)="",(Y,C)=0 I $P(^AUPNVSIT(V,0),U,7)="H" F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y I $P(^AUPNVPOV(Y,0),U,12)'="P" S C=C+1 I C=N S P=$P(^AUPNVPOV(Y,0),U),Z=Y I $P(^AUPNVSIT(V,0),U,7)'="H" S Y=0,C=-1 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y S C=C+1 I C=N S P=$P(^AUPNVPOV(Y,0),U),Z=Y I 'P Q P I '$D(^ICD9(P)) Q -1 I $G(F)="" S F="C" S %="" D @F Q % ; POV ;EP NEW Z,C,%,S S (C,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y S C=C+1 S APCLV(C)="",P=$P(^AUPNVPOV(Y,0),U),Z=Y D .I F=99 D Q ..F I=1:1 S S=$T(@I) Q:S="" S %="" D @I S $P(APCLV(C),U,I)=% .I F[";" D Q ..F J=1:1 S I=$P(F,";",J) Q:I="" I I'=99 S %="" D @I S $P(APCLV(C),U,I)=% ;IHS/TUCSON/LAB - patch 1 05/19/97 changed ,I TO ,J .S %="",I=F D @I S $P(APCLV(C),U)=% .Q Q ADMDX ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW %,Y,Z S %="",Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q % S P=$P(^AUPNVINP(Z,0),U,12) I 'P Q P I '$D(^ICD9(P)) Q -1 I $G(F)="" S F="C" S %="" D @F Q % ; I ; S %=P Q E ; S %=$P(^ICD9(P,0),U,3) Q C ; S %=$P(^ICD9(P,0),U) Q D ; S %=$P(^AUPNVPOV(Z,0),U,7) Q J ; S %=$P(^AUPNVPOV(Z,0),U,9) I % S %=$P(^ICD9(%,0),U) Q Q P ; S %=$P(^AUPNVPOV(Z,0),U,11) Q N ; S %=$P(^AUPNVPOV(Z,0),U,4) I % S %=$P(^AUTNPOV(%,0),U) Q A ; NEW I,H,R,L,E,D S I=$P(^ICD9(P,0),U) I $E(I)="." D CODE10 G HIGH S R="09"_($P(I,".")_$P(I,".",2))_" " I $E(I)="V" S I=9_$E(I,2,9999),I=I-.000001,I="09V"_$E(I,2,9999),I=$P(I,".")_$P(I,".",2)_" " G HIGH S I="09"_I-.000001 S %="",I="0"_($P(I,".")_$P(I,".",2))_" " HIGH S H=$O(^AUTTRCD("AH",I)) I H="" S %=999 Q S D=$O(^AUTTRCD("AH",H,"")) I D="" S %="" Q S E=$O(^AUTTRCD("AH",H,D,"")) S L=$P(^AUTTRCD(D,11,E,0),U)_" " I L]R S %=999 Q S %=$P(^AUTTRCD(D,0),U) Q CODE10 ; S R="10"_$P(I,".",2)_" " S I="10"_I,I=I-.000001,I=$P(I,".")_$P(I,".",2)_" " Q ; 1 ; S %=$$VD^APCLV($P(^AUPNVPOV(Y,0),U,3),"I") Q 2 ; S %=$$VD^APCLV($P(^AUPNVPOV(Y,0),U,3),"S") Q 3 ; S %=$P(^AUPNVPOV(Y,0),U,2) Q 4 ; S %=$$PATIENT^APCLV($P(^AUPNVPOV(Y,0),U,3),"E") Q 5 ; S %=Y Q 6 D E Q 7 D C Q 8 D A Q 9 D D Q 10 S %=$$VAL^XBDIQ1(9000010.07,Y,.07) Q 11 D J Q 12 D P Q 13 S %=$$VAL^XBDIQ1(9000010.07,Y,.11) Q 14 D N Q 15 S %=$P(^AUPNVPOV(Y,0),U,12) Q 16 S %=$$VAL^XBDIQ1(9000010.07,Y,.12) Q 17 S %=$$VAL^XBDIQ1(9000010.07,Y,.13) Q 18 S %=$$VAL^XBDIQ1(9000010.07,Y,.05) Q 19 S %=$$VALI^XBDIQ1(9000010.07,Y,.06) Q 20 S %=$$VAL^XBDIQ1(9000010.07,Y,.06) Q APCLV1 APCLV1 ; IHS/OHPRD/TMJ - visit entry utilities/get codes ; [ 06/02/97 3:49 PM ] ;;3.0;IHS PCC REPORTS;**1**;FEB 05, 1997 ; ;IHS/TUCSON/LAB - patch 1 modified subroutine FACTX to check ;for existence of AUTTLOC( node 3/4/97 COMM ;EP ; get COMMUNITY - STATE,COUNTY,COMMUNITY codes NEW Y,%,P,Z S %="" I '$D(^AUPNVSIT(V,0)) Q % S P=$P(^AUPNVSIT(V,0),U,5) I 'P Q % I '$D(^AUPNPAT(P)) Q % S Y=$O(^AUPNPAT(P,51,""),-1) I 'Y Q % S Z=$P(^AUPNPAT(P,51,Y,0),U,3) Q $S($G(F)="E":$P(^AUTTCOM(Z,0),U),$G(F)="C":$P(^AUTTCOM(Z,0),U,8),1:Z) ; CHART ;EP - returns ASUFAC_HRN ( 12 digits, HRN is left zero filled) NEW L,%,C,S,P,Z S %="" I '$D(^AUPNVSIT(V,0)) Q % S Z=^AUPNVSIT(V,0) S P=$P(Z,U,5) I 'P Q % I $P(Z,U,6),$D(^AUPNPAT(P,41,$P(Z,U,6),0)) S L=$P(Z,U,6) S %=$$GETCHART(L) I %]"" Q % I $G(DUZ(2)) S L=DUZ(2) S %=$$GETCHART(L) I %="" S L=$O(^AUPNPAT(P,41,0)) I L S %=$$GETCHART(L) I %="" S %=" ??????" Q % GETCHART(L) ; S S=$P(^AUTTLOC(L,0),U,10) I S="" Q S S C=$P($G(^AUPNPAT(P,41,L,0)),U,2) I C="" Q C S C=$E("000000",1,6-$L(C))_C S %=S_C Q % ; GETABBRV ; LOCENC ;EP - given visit ien V, return loc. of encounter in format F I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U,6) I Y="" Q Y I '$D(^AUTTLOC(Y)) Q -1 Q $S($G(F)="E":$P(^DIC(4,Y,0),U),$G(F)="C":$P(^AUTTLOC(Y,0),U,10),1:Y) ; VD ; EP - given visit ien in V, return date of visit in internal or external format I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U) I Y="" Q Y Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,".")) ; VDTM ;EP - given visit ien in V, return visit date and time in F format I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U) I Y="" Q Y Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2"),$G(F)="E":$$FMTE^XLFDT(Y,"1"),1:Y) ; TIME ;EP - given visit ien in V, returns visit time of day in format F I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U) I Y="" Q Y S Y=$S($G(F)="E":$$FMTE^XLFDT(Y,"2"),$G(F)="P":$$FMTE^XLFDT(Y,"2P"),1:Y) I $G(F)="P" Q $P(Y," ",2,99) I $G(F)="E" Q $P(Y,"@",2) Q $P(Y,".",2) ; LASTVD(P,F) ;PEP - given patient DFN in P, return pt's last pcc visit date, ; using the data fetcher. Returns date in format specified in F. I '$G(P) Q "" I $G(F)="" S F="I" I '$D(^AUPNVSIT("AC",P)) Q "" NEW Y,ERR,LVD S ERR=$$START1^APCLDF(P_"^LAST VISIT","LVD(") I LVD(1)="" Q LVD S Y=$P(LVD(1),U) Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,".")) ; DOW ;EP - returns I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P($P(^AUPNVSIT(V,0),U),".") I Y="" Q Y Q $S($G(F)="E":$$DOW^XLFDT(Y),1:$$DOW^XLFDT(Y,1)) ; TYPE ;EP type of visit I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U,3) Q $S(Y="":Y,$G(F)="E":$$EXTSET^XBFUNC(9000010,.03,Y),1:Y) ; SC ;EP - service category I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U,7) Q $S(Y="":Y,$G(F)="E":$$EXTSET^XBFUNC(9000010,.07,Y),1:Y) ; CLINIC ;EP - clinic I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U,8) I Y="" Q Y I '$D(^DIC(40.7,Y)) Q -1 Q $S($G(F)="E":$P(^DIC(40.7,Y,0),U),$G(F)="C":$P(^DIC(40.7,Y,0),U,2),1:Y) ; EM ;EP - eval&man cpt code I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U,17) I Y="" Q Y I '$D(^ICPT(Y)) Q -1 Q $S($G(F)="E":$P(^ICPT(Y,0),U,2),$G(F)="C":$P(^ICPT(Y,0),U),1:Y) ; LS ;EP - level of service code I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U,19) Q $S(Y="":Y,$G(F)="E":$$EXTSET^XBFUNC(9000010,.19,Y),1:Y) ; NLAB ;EP - #labs I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW %,Y S (Y,%)=0 F S Y=$O(^AUPNVLAB("AD",V,Y)) Q:Y'=+Y S %=%+1 Q % NRX ;EP - #rxs I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW %,Y S (Y,%)=0 F S Y=$O(^AUPNVMED("AD",V,Y)) Q:Y'=+Y S %=%+1 Q % ; ADMSERV ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW %,Y,Z S %="",Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q % S Y=$$VALI^XBDIQ1(9000010.02,Z,.04) Q $S('Y:%,$G(F)="C":$P($G(^DIC(45.7,Y,9999999)),U),$G(F)="I":Y,$G(F)="E":$P(^DIC(45.7,Y,0),U),1:"") DSCHSERV ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW %,Y,Z S %="",Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q % S Y=$$VALI^XBDIQ1(9000010.02,Z,.05) Q $S('Y:%,$G(F)="C":$P($G(^DIC(45.7,Y,9999999)),U),$G(F)="I":Y,$G(F)="E":$P(^DIC(45.7,Y,0),U),1:"") ADMTYPE ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW %,Y,Z S %="",Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q % S Y=$$VALI^XBDIQ1(9000010.02,Z,.07) Q $S('Y:%,$G(F)="C":$P($G(^DIC(42.1,Y,9999999)),U),$G(F)="I":Y,$G(F)="E":$P(^DIC(42.1,Y,0),U),1:"") DSCHTYPE ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW %,Y,Z S %="",Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q % S Y=$$VALI^XBDIQ1(9000010.02,Z,.06) Q $S('Y:%,$G(F)="C":$P($G(^DIC(42.2,Y,9999999)),U),$G(F)="I":Y,$G(F)="E":$P(^DIC(42.2,Y,0),U),1:"") DSCHDATE ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y,Z S Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q Z S Y=$P(^AUPNVINP(Z,0),U) I Y="" Q Y Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,".")) CONSULTS ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y,Z I $P(^AUPNVSIT(V,0),U,7)'="H" Q "" S Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q Z Q $P(^AUPNVINP(Z,0),U,8) LOS ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y,Z,X,X1,X2 S Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q Z S X1=$P($P(^AUPNVINP(Z,0),U),"."),X2=$P($P(^AUPNVSIT($P(^AUPNVINP(Z,0),U,3),0),U),".") D ^%DTC S:X=0 X=1 Q X FACTX ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW %,Y,Z S %="",Z=$O(^AUPNVINP("AD",V,0)) I 'Z Q % I F="I" Q $$VALI^XBDIQ1(9000010.02,Z,.09) I F="C" S Y=$$VALI^XBDIQ1(9000010.02,Z,.09) S Y=+Y S Y=$S('Y:"",$D(^AUTTLOC(Y,0)):$P(^AUTTLOC(Y,0),U,10),1:"") Q Y ;IHS/TUCSON/LAB - patch1 changed this line to check for existence of AUTTLOC node 3/4/97 Q $$VAL^XBDIQ1(9000010.02,Z,.09) ACTTIME ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$O(^AUPNVTM("AD",V,0)) I 'Y Q Y Q $$VALI^XBDIQ1(9000010.19,Y,.01) TRAVTIME ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$O(^AUPNVTM("AD",V,0)) I 'Y Q Y Q $$VALI^XBDIQ1(9000010.19,Y,.04) CHSCOST ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$O(^AUPNVCHS("AD",V,0)) I 'Y Q Y Q $$VALI^XBDIQ1(9000010.03,Y,.06) ; PATIENT ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U,5) I Y="" Q Y I '$D(^DPT(Y)) Q -1 Q $S($G(F)="E":$P(^DPT(Y,0),U),$G(F)="C":$$CHART^APCLV(V),1:Y) ; DLM ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U,13) I Y="" Q Y Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,".")) ; DVEX ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U,14) I Y="" Q Y Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,".")) ; APWI ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U,16) Q $S(Y="":Y,$G(F)="E":$$EXTSET^XBFUNC(9000010,.16,Y),1:Y) ; CODT ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U,18) I Y="" Q Y Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,".")) ; APDT ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y S Y=$P(^AUPNVSIT(V,0),U,25) I Y="" Q Y Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,".")) OUTSL ;EP I 'V Q -1 I '$D(^AUPNVSIT(V)) Q -1 NEW Y Q $P($G(^AUPNVSIT(V,21)),U) ; PCHART ;EP NEW %,C,S,Z S %="" I '$D(^AUPNPAT(P,0)) Q % I 'L Q % I '$D(^AUPNPAT(P,41,L,0)) Q % S %=$$GETCHART(L) I %="" S %=" ??????" S %=$P(^AUTTLOC(L,0),U,7)_$E(%,7,12) Q % APCLV2 APCLV2 ;IHS/TUCSON/LAB - get values for stat record [ 03/06/98 8:36 AM ] ;;3.0;IHS PCC REPORTS;**1,2**;MAR 05, 1998 ; ;IHS/TUCSON/LAB - patch 1 - 06/02/97 - added this new routine to ;support additions to the statistical database record ;;CMI/LAB - Patch 2 -02/23/98 - modified subroutines ACE and DMNUTR ;;to fix problems with the data being passed to the data center ; HGBA1C(V) ;EP - called to return value of HGBA1C if done on this visit ;V is visit ien NEW R S R="" I '$D(^AUPNVSIT(V)) Q R I '$D(^AUPNVLAB("AD",V)) Q R ;no v labs to check I '$D(^ATXLAB("B","DM AUDIT HGB A1C TAX")) Q R NEW Y S Y=$O(^ATXLAB("B","DM AUDIT HGB A1C TAX",0)) I 'Y Q R ;no taxonomy to look at NEW X,Z S X=0 F S X=$O(^AUPNVLAB("AD",V,X)) Q:X'=+X S Z=$P(^AUPNVLAB(X,0),U) I $D(^ATXLAB(Y,21,"B",Z)) S R=$P(^AUPNVLAB(X,0),U,4) Q R ; HTN(P) ;EP - is htn documented for this patient ever? Y or N retured NEW R,X,E,APCLV2 S R="" I '$D(^DPT(P)) Q R I $P(^DPT(P,0),U,19) Q R I '$D(^AUPNVPOV("AC",P)) Q R ;no povs on file NEW X,E S X=P_"^LAST DX [SURVEILLANCE HYPERTENSION" S E=$$START1^APCLDF(X,"APCLV2(") Q $P($G(APCLV2(1)),U) ; BP(V) ;EP - systolic pressure this visit ;V is visit ien I '$D(^AUPNVSIT(V)) Q "" I '$D(^AUPNVMSR("AD",V)) Q "" NEW Y S Y=$O(^AUTTMSR("B","BP",0)) I 'Y Q "" NEW X,Z,R S R="" S X=0 F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X I $P(^AUPNVMSR(X,0),U)=Y S R=$P(^AUPNVMSR(X,0),U,4) Q R ; ACE(V) ;EP - ace inhibitor filled this visit ;V is visit ien I '$D(^AUPNVSIT(V)) Q "" I '$D(^AUPNVMED("AD",V)) Q "N" ;no v meds to check NEW Y S Y=$O(^ATXAX("B","DM AUDIT ACE INHIBITORS",0)) I 'Y Q "" ;CMI/LAB 02/23/98 Patch #2 Modified subroutine to fix problems with ;data being passed to the Data Center. ;Added R to NEW statement below and added the setting of R="" ;in the line that follows ;BEG ORG CODE ;NEW X,Z ;END ORG CODE ;BEG NEW CODE NEW X,Z,R S R="" ;END NEW CODE S X=0 F S X=$O(^AUPNVMED("AD",V,X)) Q:X'=+X S Z=$P(^AUPNVMED(X,0),U) I $D(^ATXAX(Y,21,"B",Z)) S R=1 Q $S($G(R):"Y",1:"N") ; RW(V) ;EP called to return %recommended weight I '$G(V) Q "" I '$D(^AUPNVSIT(V)) Q "" I '$D(^AUPNVMSR("AD",V)) Q "" NEW Y S Y=$O(^AUTTMSR("B","WT",0)) I 'Y Q "" NEW X,Z,R S R="" S X=0 F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X I $P(^AUPNVMSR(X,0),U)=Y S R=$P(^AUPNVMSR(X,0),U,4) S R=$$RW^APCL2A3($P(^AUPNVSIT(V,0),U,5),R,$P(^AUPNVSIT(V,0),U)) Q R ; DMNUTR(V) ;EP - was dm nutrition educ done on this visit, Y or N I '$G(V) Q "N" I '$D(^AUPNVSIT(V)) Q "N" I '$D(^AUPNVPED("AD",V)) Q "N" NEW Y S Y=$O(^ATXAX("B","APCL DM NUTRITION EDUC TOPICS",0)) I 'Y Q "" ;CMI/LAB 02/23/98 Patch #2 - Modified subroutine to fix problems with ;data being passed to the Data Center ;Added R to NEW statement below and added the setting of R="" ;in the line that follows. ;BEG ORG CODE ;NEW X,Z ;END ORG CODE ;BEG NEW CODE NEW X,Z,R S R="" ;END NEW CODE S X=0 F S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X S Z=$P(^AUPNVPED(X,0),U) I $D(^ATXAX(Y,21,"B",Z)) S R=1 Q $S($G(R):"Y",1:"N") ; HC(V) ;EP - return y or n if head circumference done ;V is visit ien I '$D(^AUPNVSIT(V)) Q "" I '$D(^AUPNVMSR("AD",V)) Q "N" NEW Y S Y=$O(^AUTTMSR("B","HC",0)) I 'Y Q "" NEW X,Z,R S R="" S X=0 F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X I $P(^AUPNVMSR(X,0),U)=Y S R=1 Q $S($G(R):"Y",1:"N") ; ; DISPER(V) ;EP - called to get ER disposition I '$G(V) Q "" I '$D(^AUPNVSIT(V)) Q "" I $$CLINIC^APCLV(V,"C")'=30 Q "" NEW Y S Y=$O(^AUPNVER("AD",V,0)) I 'Y Q "" Q $$VALI^XBDIQ1(9000010.29,Y,.11) APCLVLP APCLVLP ; IHS/OHPRD/TMJ - PRINT VISIT REPORT ; [ 06/02/97 3:49 PM ] ;;3.0;IHS PCC REPORTS;**1**;FEB 05, 1997 ;IHS/TUCSON/LAB - added killing of APCLPRNT to V subroutine 05/19/97 ;IHS/TUCSON/LAB - modified subroutine FLAT - patch 1 - 05/27/97 START ;EP - Set up header line, dash line S APCLFCNT=0 K ^XTMP($J,"APCLFLAT") ;just in case S X=0,APCLHEAD="" F S X=$O(^APCLVRPT(APCLRPT,12,X)) Q:X'=+X S APCLHDR=$P(^APCLVSTS($P(^APCLVRPT(APCLRPT,12,X,0),U),0),U,6),APCLLENG=$P(^APCLVRPT(APCLRPT,12,X,0),U,2),APCLHDR=$E(APCLHDR,1,APCLLENG) D .S J=$L(APCLHDR),APCLHEAD=APCLHEAD_APCLHDR,K=$P(^APCLVRPT(APCLRPT,12,X,0),U,2)+1 F I=J:1:K S APCLHEAD=APCLHEAD_" " .Q S APCLDASH="",$P(APCLDASH,"-",APCLTCW)="-" D COVPAGE^APCLVLP1 ;print cover page - note: if user ^'s out of cover page, processing continues PROC ;process printing of report I APCLCTYP="T" G DONE ;--- if displaying only total, that was done in the cover page - go to done I APCLCTYP="C" G DONE ;--- if doing a template, that's already done so goto done S APCLPG=0 I '$D(^XTMP("APCLVL",APCLJOB,APCLBTH)) G DONE S (APCLSRTV,APCLFRST)="" K APCLQUIT F S APCLSRTV=$O(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV)) Q:APCLSRTV=""!($D(APCLQUIT)) D V G:$D(APCLQUIT) DONE I APCLCTYP="F" D G DONE .D WRITEF .W:'$D(ZTQUEUED) !!,"Flat file ",APCLFILE," has been created." .W:'$D(ZTQUEUED) !,"Total number of visits counted in selection process: ",APCLRCNT .W:'$D(ZTQUEUED) !,"Total number of visits that generated Area Database records: ",(APCLFCNT/3) ;IHS/TUCSON/LAB - PATCH 1 - 05/27/97 changed 2 to 3 .W:'$D(ZTQUEUED) !!,"If there is a discrepency in the counts it is because some of the visits",!,"that met the selection criteria may have been incomplete, or ",!,"generated an error while the area database record was being created." .W:'$D(ZTQUEUED) !,"Errors that could occur would be similar to errors seen on the PCC Visit",!,"review reports.",! I $Y>(IOSL-4) D HEAD G:$D(APCLQUIT) DONE I $D(APCLRCNT) W !!!,"Total ",$S(APCLPTVS="P":"Patients",1:"Visits"),": ",APCLRCNT I $G(APCLPTVS)="V" W !,"Total Patients: ",APCLPTCT DONE ; D DONE^APCLVLP2 Q V ;GETS DATA HITS S APCLSCNT=0 ;get readable sort value K APCLPRNT ;IHS/TUCSON/LAB - added this kill to prevent wrong value patch 1 05/19/97 S APCLSRTR="",APCLVIEN=$O(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV,0)) I APCLVIEN]"" S APCLCRIT=APCLSORT D .I APCLPTVS="V" S APCLVREC=^AUPNVSIT(APCLVIEN,0),DFN=$P(APCLVREC,U,5) X:$D(^APCLVSTS(APCLSORT,3)) ^(3) S APCLSRTR=APCLPRNT .I APCLPTVS="P" S DFN=APCLVIEN X:$D(^APCLVSTS(APCLSORT,3)) ^(3) S APCLSRTR=APCLPRNT I $G(APCLSPAG)!($D(APCLFRST)) D HEAD Q:$D(APCLQUIT) K APCLFRST S APCLVIEN=0 F S APCLVIEN=$O(^XTMP("APCLVL",APCLJOB,APCLBTH,"DATA HITS",APCLSRTV,APCLVIEN)) Q:APCLVIEN'=+APCLVIEN!($D(APCLQUIT)) D .I APCLPTVS="V" S APCLVREC=^AUPNVSIT(APCLVIEN,0),DFN=$P(APCLVREC,U,5) D PRINT Q .S DFN=APCLVIEN D PRINT .Q Q:$D(APCLQUIT) I $Y>(IOSL-3) D HEAD Q:$D(APCLQUIT) I $G(APCLSPAG) W !!,"SUB-TOTAL for ",APCLSORV," ",APCLSRTR,": ",APCLSCNT I APCLPTVS="V" W " # of PATIENTS: ",$S($D(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRTV)):^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRTV),1:0) I APCLCTYP="S",(APCLPTVS="V") W !,?10,$E(APCLSRTR,1,30),?45,$J(APCLSCNT,8)," (V)",?60,$S($D(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRTV)):$J(^XTMP("APCLVL",APCLJOB,APCLBTH,"SUB PAT COUNT",APCLSRTV),8),1:0)," (P)" I APCLCTYP="S",(APCLPTVS="P") W !,?10,$E(APCLSRTR,1,30),?45,$J(APCLSCNT,8) Q PRINT ; I APCLCTYP="F" D FLAT Q S APCLSCNT=APCLSCNT+1 Q:APCLCTYP="S" K ^XTMP("APCLLINE",$J) S ^XTMP("APCLLINE",$J,1)="" I $Y>(IOSL-5) D HEAD Q:$D(APCLQUIT) S APCLI=0 F S APCLI=$O(^APCLVRPT(APCLRPT,12,APCLI)) Q:APCLI'=+APCLI!($D(APCLQUIT)) S APCLCRIT=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U) D .I '$P(^APCLVSTS(APCLCRIT,0),U,8) D SINGLE Q .D MULT .Q S APCLX=0 F S APCLX=$O(^XTMP("APCLLINE",$J,APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT)) D .I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT) .W !,^XTMP("APCLLINE",$J,APCLX) Q SINGLE ;process single valued item K APCLPRNT S APCLX=0 X:$D(^APCLVSTS(APCLCRIT,3)) ^(3) S APCLLENG=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2),APCLPRNT=$E(APCLPRNT,1,APCLLENG) D .S J=$L(APCLPRNT),^XTMP("APCLLINE",$J,1)=^XTMP("APCLLINE",$J,1)_APCLPRNT,K=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1 F I=J:1:K S ^XTMP("APCLLINE",$J,1)=^XTMP("APCLLINE",$J,1)_" " .S X=1 F S X=$O(^XTMP("APCLLINE",$J,X)) Q:X'=+X I $L(^XTMP("APCLLINE",$J,X))<$L(^XTMP("APCLLINE",$J,1)) S K=$L(^XTMP("APCLLINE",$J,X))+1,J=$L(^XTMP("APCLLINE",$J,1)) F I=K:1:J S ^XTMP("APCLLINE",$J,X)=^XTMP("APCLLINE",$J,X)_" " Q MULT ; K APCLPRNT,APCLPRNM,APCLY S (APCLX,APCLPCNT)=0 X:$D(^APCLVSTS(APCLCRIT,3)) ^(3) I '$D(APCLPRNM) S APCLPRNT="--" D .S APCLLENG=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2),APCLPRNT=$E(APCLPRNT,1,APCLLENG) D ..S J=$L(APCLPRNT),^XTMP("APCLLINE",$J,1)=^XTMP("APCLLINE",$J,1)_APCLPRNT,K=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1 F I=J:1:K S ^XTMP("APCLLINE",$J,1)=^XTMP("APCLLINE",$J,1)_" " S X=0 F S X=$O(APCLPRNM(X)) Q:X'=+X D .I X=1 D Q ..S APCLLENG=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2),APCLPRNT=$E(APCLPRNM(1),1,APCLLENG) D ...S J=$L(APCLPRNT),^XTMP("APCLLINE",$J,1)=^XTMP("APCLLINE",$J,1)_APCLPRNT,K=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1 F I=J:1:K S ^XTMP("APCLLINE",$J,1)=^XTMP("APCLLINE",$J,1)_" " .S APCLLENG=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2),APCLPRNT=$E(APCLPRNM(X),1,APCLLENG) D ..I '$D(^XTMP("APCLLINE",$J,X)) S ^XTMP("APCLLINE",$J,X)="",K=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1,$P(^XTMP("APCLLINE",$J,X)," ",($L(^XTMP("APCLLINE",$J,1))-K))="" ..S J=$L(APCLPRNT),^XTMP("APCLLINE",$J,X)=^XTMP("APCLLINE",$J,X)_APCLPRNT,K=$P(^APCLVRPT(APCLRPT,12,APCLI,0),U,2)+1 F I=J:1:K S ^XTMP("APCLLINE",$J,X)=^XTMP("APCLLINE",$J,X)_" " S X=1 F S X=$O(^XTMP("APCLLINE",$J,X)) Q:X'=+X I $L(^XTMP("APCLLINE",$J,X))<$L(^XTMP("APCLLINE",$J,1)) S K=$L(^XTMP("APCLLINE",$J,X))+1,J=$L(^XTMP("APCLLINE",$J,1)) F I=K:1:J S ^XTMP("APCLLINE",$J,X)=^XTMP("APCLLINE",$J,X)_" " Q DIQ ; K APCLPRNT,APCLFILE,APCLFIEL S APCLFILE=$P($P(^APCLVSTS(APCLCRIT,0),U,4),","),APCLFIEL=$P($P(^(0),U,4),",",2) S DIQ(0)="EN",DIQ="APCLPRNT(",DIC=APCLFILE,DR=APCLFIEL D EN^DIQ1 K DIC,DR,DIQ I '$D(APCLPRNT(APCLFILE,DA,APCLFIEL,"E")) S APCLPRNT(APCLFILE,DA,APCLFIEL,"E")="--" S APCLPRNT=APCLPRNT(APCLFILE,DA,APCLFIEL,"E") Q FLAT ; ;IHS/TUCSON/LAB - modified this subroutine to add a third record patch 1 05/27/97 K APCLX1,APCLX2,APCLX3 ;IHS/TUCSON/LAB - added kill of APCLX3 S APCLX1=$$VREC^APCLVDR(APCLVIEN,"MEGA RECORD 1") Q:APCLX1="" Q:APCLX1=-1 S APCLX2=$$VREC^APCLVDR(APCLVIEN,"MEGA RECORD 2") G:APCLX2="" FLATX G:APCLX2=-1 FLATX S APCLX3=$$VREC^APCLVDR(APCLVIEN,"MEGA RECORD 3") Q:APCLX3="" G:APCLX3=-1 FLATX S APCLFCNT=APCLFCNT+1,^XTMP($J,"APCLFLAT",APCLFCNT)=APCLX1 S APCLFCNT=APCLFCNT+1,^XTMP($J,"APCLFLAT",APCLFCNT)=APCLX2 S APCLFCNT=APCLFCNT+1,^XTMP($J,"APCLFLAT",APCLFCNT)=APCLX3 FLATX K APCLX1,APCLX2,APCLV0,APCLX3 Q HEAD ;ENTRY POINT D HEAD^APCLVLP2 Q WRITEF ;write flat file from global D WRITEF^APCLVLP2 Q