1:45 PM 6-MAR-98 APCL Patch 2 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 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 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 APCLT1 APCLT1 ; IHS/OHPRD/TMJ - TOP T POVS ; [ 06/02/97 3:47 PM ] ;;3.0;IHS PCC REPORTS;**1**;FEB 05, 1997 ; ;IHS/TUCSON/LAB - added subroutine APWI for patch 1 to allow ;selection by appointment or walkin 05/01/97 ; W !!?20,"***** WAITING TIMES BY CLINIC AND PROVIDER *****",!! W !,"This report will display minimum, maximum and mean waiting times by provider,",!,"and clinic. In order to have any data for this report, you must be entering",!,"the time the primary provider saw the patient.",!! D EXIT GETDATES ; BD ;get beginning date W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Visit Date" D ^DIR S:$D(DUOUT) DIRUT=1 K DIR S:$D(DUOUT) DIRUT=1 I $D(DIRUT) G EXIT S APCLBD=Y ED ;get ending date W ! S DIR(0)="D^"_APCLBD_":DT:EP",DIR("A")="Enter ending Visit Date" S Y=APCLBD D DD^%DT D ^DIR S:$D(DUOUT) DIRUT=1 K DIR S:$D(DUOUT) DIRUT=1 I Y="" G BD I $D(DIRUT) G BD S APCLED=Y S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X S Y=APCLBD D DD^%DT S APCLBDD=Y S Y=APCLED D DD^%DT S APCLEDD=Y ; CLINIC ; K APCLCLNT W ! S DIR(0)="Y",DIR("A")="Tally Waiting Times for ALL clinics" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 G:$D(DIRUT) BD I Y=1 G APWI CLINIC1 ; S X="CLINIC",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" G EXIT D ^AMQQGTX0(+Y,"APCLCLNT(") I '$D(APCLCLNT) G CLINIC I $D(APCLCLNT("*")) K APCLCLNT APWI ;ask appt or walk ins ;IHS/TUCSON/LAB - added this subroutine patch 1 05/01/97 S APCLAPWI="" S DIR(0)="S^W:WALK-INS Only;A:APPOINTMENTS Only",DIR("A")="Do you wish to include",DIR("B")="A" KILL DA D ^DIR KILL DIR G:$D(DIRUT) CLINIC S APCLAPWI=Y ;IHS/TUCSON/LAB - 05/01/97 of patch 1 ZIS ; S XBRC="PROC^APCLT1",XBRP="^APCLT1P",XBNS="APCL",XBRX="EXIT^APCLT1" D ^XBDBQUE D EXIT Q EXIT ; K APCLBD,APCLBDD,APCLSD,APCLED,APCLEDD,APCLCLNT,APCLAPPT,APCLBD,APCLBDD,APCLVT,APCLBTH,APCLCI,APCLCN,APCDT,APCLED,APCLEDD,APCLAPWI K APCLJOB,APCLLENG,APCLLOCT,APCLODAT,APCLPG,APCLPP,APCLPPS,APCLQUIT,APCLSD,APCLSEC,APCLTOT,APCLTOTV,APCLVIEN,APCLVREC,APCLX Q PROC ;EP - called from xbdbque S APCLTOTV=0 S (APCLBTH,APCLBT)=$H,APCLJOB=$J K ^XTMP("APCLT1",APCLJOB,APCLBTH) D XTMP^APCLOSUT("APCLT1","PCC CLINIC WAIT TIMES REPORT") ; V ; Run by visit date S APCLODAT=APCLSD_".9999" F S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>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