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

APCLOS3.m

Go to the documentation of this file.
  1. APCLOS3 ; IHS/CMI/LAB - CHS PORTION OF OS ;
  1. ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1. ;IHS/CMI/LAB - fixed newborn counts, admitting dx patch 4
  1. ;
  1. ;IHS/TUCSON/LAB - modified routine to use B index on ACHSF to avoid
  1. ;errors - patch 1 - 06/02/97
  1. ;
  1. CHS ;
  1. S APCLOS="APCLOS",APCLODAT=APCLFYB,APCLEDAT=APCLFYE D CHS0
  1. S APCLOS="APCLOSP",APCLODAT=APCLPYB,APCLEDAT=APCLPYE D CHS0
  1. K APCLODAT,APCLF,APCLN,APCLCHSR,APCLEDAT,APCLTOS,APCLPAY,APCLTOSE
  1. Q
  1. 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
  1. ;IHS/TUCSON/LAB - modified above to use B index patch 1 06/02/97
  1. Q
  1. CHS1 ;
  1. S APCLN=0 F S APCLN=$O(^ACHSF(APCLF,"D",APCLN)) Q:APCLN'=+APCLN S APCLCHSR=^ACHSF(APCLF,"D",APCLN,0) D CHS2
  1. Q
  1. CHS2 ;
  1. Q:$P(APCLCHSR,U,2)<APCLODAT
  1. Q:$P(APCLCHSR,U,2)>APCLEDAT
  1. ;I $E(APCLFY,2)'=$P(APCLCHSR,U,14) Q
  1. S APCLTOS=$P(APCLCHSR,U,4)
  1. 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
  1. K ^UTILITY("DIQ1",$J)
  1. K DIQ,DIC,DA,DR
  1. ;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
  1. S APCLTOSE=$S(APCLTOS=1:"43 - HOSPITALIZATION",APCLTOS=2:"57 - DENTAL",APCLTOS=3:"64 - NON-HOSPITAL SERVICE",1:"UNKNOWN")
  1. ;S APCLTOSE=^UTILITY("DIQ1",$J,9002080.01,APCLF,APCLN)
  1. S:APCLTOS="" APCLTOS=9999999999
  1. S ^(APCLTOSE)=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"CHS",APCLTOS,APCLTOSE)):+^(APCLTOSE)+APCLPAY,1:APCLPAY)
  1. S ^(APCLTOSE)=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"CHSCOUNT",APCLTOS,APCLTOSE)):+^(APCLTOSE)+1,1:1)
  1. K ^UTILITY("DIQ1",$J)
  1. S ^("CHSTOTAL")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"CHSTOTAL")):+^("CHSTOTAL")+APCLPAY,1:APCLPAY)
  1. Q
  1. INPT ;
  1. S APCLNBCD=$O(^DIC(45.7,"CIHS","07","")),APCLNBC("APCLOS")=0,APCLNBC("APCLOSP")=0,APCLNBDY("APCLOS")=0,APCLNBDY("APCLOSP")=0 ;IHS/TUCSON/LAB - FIXED APCLNBC array and APCLNBDY array
  1. S APCLOS="APCLOS",%="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,",APCLA=%_"""INPTPOV"",APCLPOV)",APCLC=%_"""INPTPOVC"""_")",APCLB=%_"""INPTADMDX"",APCLADX)",APCLD=%_"""INPTADMDXC"""_")"
  1. S APCLODAT=APCLFYB-.0001,APCLEDAT=APCLFYE D V
  1. S APCLOS="APCLOSP",%="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,",APCLA=%_"""INPTPOV"",APCLPOV)",APCLC=%_"""INPTPOVC"""_")",APCLB=%_"""INPTADMDX"",APCLADX)",APCLD=%_"""INPTADMDXC"""_")"
  1. S APCLODAT=APCLPYB-.0001,APCLEDAT=APCLPYE D V
  1. D ALOS
  1. K APCLA,APCLODAT,APCLC,APCLHREC,APCL1,APCL2,APCLVREC,APCLPOV,%,APCLEDAT,APCLLOS,APCLVDFN,APCLVINP,APCLVLOC
  1. Q
  1. ;
  1. V ; Run by visit date
  1. F S APCLODAT=$O(^AUPNVINP("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLEDAT) D V1
  1. D SET
  1. Q
  1. V1 ;
  1. S APCLVINP="" F S APCLVINP=$O(^AUPNVINP("B",APCLODAT,APCLVINP)) Q:APCLVINP'=+APCLVINP I $D(^AUPNVINP(APCLVINP,0)) S APCLHREC=^(0) D PROC
  1. Q
  1. PROC ;
  1. Q:$$DEMO^APCLUTL($P(APCLHREC,U,2),$G(APCLDEMO))
  1. S APCLVDFN=$P(APCLHREC,U,3)
  1. S APCLVREC=^AUPNVSIT(APCLVDFN,0)
  1. Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3))) ;LAB/OHPRD changed CV to V for VA
  1. S APCLVLOC=$P(APCLVREC,U,6)
  1. Q:'$D(^XTMP("APCLSU",APCLJOB,APCLBTH,APCLVLOC))
  1. Q:'$D(^AUPNVPOV("AD",APCLVDFN))
  1. Q:'$D(^AUPNVPRV("AD",APCLVDFN))
  1. 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)
  1. Q:APCL1=0
  1. Q:APCL1>1
  1. ;IHS/TUCSON/LAB - fixed setting of APCLNBC AND APCLNBDY
  1. I APCLNBCD]"",$P(APCLHREC,U,5)=APCLNBCD S APCLNBC(APCLOS)=APCLNBC(APCLOS)+1 D
  1. .S X1=$P(APCLODAT,"."),X2=$P((APCLVREC/1),".") D ^%DTC S APCLLOS=X S:APCLLOS=0 APCLLOS=1 S APCLNBDY(APCLOS)=APCLNBDY(APCLOS)+APCLLOS
  1. Q:$P(APCLHREC,U,5)=APCLNBCD
  1. S ^("DISCH")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"DISCH")):(+^("DISCH")+1),1:1)
  1. S X1=$P(APCLODAT,"."),X2=$P((APCLVREC/1),".") D ^%DTC S APCLLOS=X S:APCLLOS=0 APCLLOS=1
  1. S ^("PATDAYS")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"PATDAYS")):+^("PATDAYS")+APCLLOS,1:APCLLOS)
  1. D ADMDX
  1. Q:APCLPOV=""
  1. Q:'$D(^ICD9(APCLPOV,0))
  1. S X=APCLA
  1. ;
  1. I '$D(@X) S @X=0
  1. S %=@X,%=%+1,@X=%
  1. Q
  1. ;
  1. ;CMI/LAB - added the following to tally admitting dxs
  1. ADMDX ;
  1. S APCLADX=$P(APCLHREC,U,12)
  1. Q:APCLADX=""
  1. Q:'$D(^ICD9(APCLADX,0))
  1. S X=APCLB
  1. I '$D(@X) S @X=0
  1. S %=@X,%=%+1,@X=%
  1. Q
  1. SET ;
  1. F APCLPOV=0:0 S APCLPOV=$O(@APCLA) Q:'APCLPOV S %=^(APCLPOV) S ^XTMP(APCLOS,APCLJOB,APCLBTH,"INPTPOVC",9999999-%,APCLPOV)=%
  1. F APCLADX=0:0 S APCLADX=$O(@APCLB) Q:'APCLADX S %=^(APCLADX) S ^XTMP(APCLOS,APCLJOB,APCLBTH,"INPTADMDXC",9999999-%,APCLADX)=%
  1. Q
  1. ALOS ;
  1. S APCLOS="APCLOS" D ALOS1
  1. S APCLOS="APCLOSP" D ALOS1
  1. Q
  1. ALOS1 ;
  1. Q:'$D(^XTMP(APCLOS,APCLJOB,APCLBTH,"DISCH"))
  1. S ^XTMP(APCLOS,APCLJOB,APCLBTH,"ALOS")=(^XTMP(APCLOS,APCLJOB,APCLBTH,"PATDAYS")/^XTMP(APCLOS,APCLJOB,APCLBTH,"DISCH"))
  1. S ^XTMP(APCLOS,APCLJOB,APCLBTH,"ALOS")=$J(^XTMP(APCLOS,APCLJOB,APCLBTH,"ALOS"),1,1)
  1. Q