- 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