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