- APCLOS4 ; IHS/CMI/LAB - AMBULATORY - OPERATIONS SUMMARY ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;
- AMB ;
- S X=999,DIC="^AUTTRCD(",DIC(0)="" D ^DIC S APCLAPCD=$S(Y>0:+Y,1:"")
- I $G(APCLMFY)=1!(APCLMFY=3) S X1=APCLFYB,X2=-1 D C^%DTC S APCLSD=X_".9999",APCLED=APCLFYE,APCLOS="APCLOS" D V
- I $G(APCLMFY)=2 S APCLSD=APCL("FY WORKING DT"),APCLED=APCLFYE,APCLOS="APCLOS" D V
- D SET^APCLOSUT
- S X1=APCLPYB,X2=-1 D C^%DTC S APCLSD=X_".9999",APCLED=APCLPYE,APCLOS="APCLOSP" D V
- D SET^APCLOSUT
- EOJ ;ENTRY POINT
- K APCLSD,APCLODAT,APCLED,APCLVDFN,APCLVREC,APCLINJF,APCLALCH,APCLVLOC,APCL1,APCL2,APCLAP,APCLTYPE,APCLCAT,APCLVLOC,APCLCLNC,APCLCLIN,APCLDDFN,APCLDENT,APCLF,APCLPOV,APCLINJ,APCLAPC,G
- K APCLX,APCLPROV,APCLY,APCLDISC,APCLPDFN,APCLA,APCLH,APCLD,APCLAMB,APCLEDAT,APCLL,APCLS,APCLC,APCLT,APCLP,APCLF,APCLH,APCLAPCD
- Q
- V ;
- S %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,",APCLA=%_"""AMBPOV"",APCLPOV)"
- S %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,",APCLH=%_"""AMBAPC"",APCLAPC)"
- S %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,",APCLD=%_"""AMBINJCAUSE"",APCLINJ)"
- S %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,",APCLF=%_"""DENTPOV"",APCLDENT)"
- S %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,",APCLP=%_"""AMBPROV"",APCLDISC)"
- S %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,",APCLT=%_"""AMBTYPE"",APCLTYPE)"
- S %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,",APCLL=%_"""AMBLOC"",APCLVLOC)"
- S %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,",APCLS=%_"""AMBCAT"",APCLCAT)"
- S %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,",APCLC=%_"""AMBCLIN"",APCLCLIN)"
- S APCLODAT=APCLSD F S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED) D V1
- Q
- V1 ;
- S APCLVDFN="" F S APCLVDFN=$O(^AUPNVSIT("B",APCLODAT,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN I $D(^AUPNVSIT(APCLVDFN,0)) S APCLVREC=^(0) D PROC
- Q
- PROC ;
- K APCLINJF,APCLALCH
- Q:$$DEMO^APCLUTL($P(APCLVREC,U,5),$G(APCLDEMO))
- Q:'$P(APCLVREC,U,9)
- Q:$P(APCLVREC,U,11)
- Q:"DXEIH"[$P(APCLVREC,U,7)
- I $P(APCLVREC,U,3)="" Q
- Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3))) ;LAB/OHPRD CHANGED CV TO C FOR VA
- S APCLVLOC=$P(APCLVREC,U,6) Q:APCLVLOC=""
- Q:'$D(^XTMP("APCLSU",APCLJOB,APCLBTH,APCLVLOC))
- Q:'$D(^AUPNVPOV("AD",APCLVDFN))
- S (APCL1,APCL2)=0 F S APCL2=$O(^AUPNVPRV("AD",APCLVDFN,APCL2)) Q:APCL2="" I $P(^AUPNVPRV(APCL2,0),U,4)="P" S APCL1=APCL1+1,APCLAP=$P(^(0),U)
- Q:APCL1=0
- Q:APCL1>1
- I $P(APCLVREC,U,7)="C" S ^("CHART REVIEWS")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"CHART REVIEWS")):(+^("CHART REVIEWS")+1),1:1) Q
- S ^("AMBVCOUNT")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"AMBVCOUNT")):(+^("AMBVCOUNT")+1),1:1)
- TYPE K ^UTILITY("DIQ1",$J)
- K DIQ,DIC,DA,DR
- S DIC="^AUPNVSIT(",DR=".03",DA=APCLVDFN,DIQ(0)="E" D EN^DIQ1 K DIC,DA,DR,DIQ
- S APCLTYPE=^UTILITY("DIQ1",$J,9000010,APCLVDFN,.03,"E")
- S X=APCLT D COUNT
- SC ;
- K ^UTILITY("DIQ1",$J)
- K DIQ,DIC,DA,DR
- S DIC="^AUPNVSIT(",DR=".07",DA=APCLVDFN,DIQ(0)="E" D EN^DIQ1 K DIC,DA,DR,DIQ
- S APCLCAT=^UTILITY("DIQ1",$J,9000010,APCLVDFN,.07,"E")
- S X=APCLS D COUNT
- K ^UTILITY("DIQ1",$J)
- LOC ;
- S X=APCLL D COUNT
- CLINIC ;
- S APCLCLIN=$P(APCLVREC,U,8) I APCLCLIN="" S APCLCLIN="NO CLINIC",APCLCLNC="" G SETCLIN
- S APCLCLNC=$P(^DIC(40.7,APCLCLIN,0),U,2),APCLCLIN=$P(^DIC(40.7,APCLCLIN,0),U)
- SETCLIN ;
- S X=APCLC D COUNT
- I APCLCLNC=30 S ^("ERCOUNT")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"ERCOUNT")):(+^("ERCOUNT")+1),1:1)
- I APCLCLNC=56 D DENTAL
- ;
- PROV D ^APCLOS41
- Q
- DENTAL ;
- S ^("DENTVCOUNT")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"DENTVCOUNT")):(+^("DENTVCOUNT")+1),1:1)
- S APCLDDFN=0 F S APCLDDFN=$O(^AUPNVDEN("AD",APCLVDFN,APCLDDFN)) Q:APCLDDFN'=+APCLDDFN I $D(^AUPNVDEN(APCLDDFN,0)) D DENTAL1
- Q
- DENTAL1 ;
- S APCLDENT=$P(^AUPNVDEN(APCLDDFN,0),U)
- S X=APCLF D COUNT
- ;
- Q:$D(^XTMP(APCLOS,APCLJOB,APCLBTH,"DENTPAT",$P(^AUPNVDEN(APCLDDFN,0),U,2)))
- S ^XTMP(APCLOS,APCLJOB,APCLBTH,"DENTPAT",$P(^AUPNVDEN(APCLDDFN,0),U,2))=""
- S ^("DENTPATCOUNT")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"DENTPATCOUNT")):(+^("DENTPATCOUNT")+1),1:1)
- Q
- COUNT ;
- I '$D(@X) S @X=0
- S %=@X,%=%+1,@X=%
- Q
- APCLOS4 ; IHS/CMI/LAB - AMBULATORY - OPERATIONS SUMMARY ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +2 ;
- AMB ;
- +1 SET X=999
- SET DIC="^AUTTRCD("
- SET DIC(0)=""
- DO ^DIC
- SET APCLAPCD=$SELECT(Y>0:+Y,1:"")
- +2 IF $GET(APCLMFY)=1!(APCLMFY=3)
- SET X1=APCLFYB
- SET X2=-1
- DO C^%DTC
- SET APCLSD=X_".9999"
- SET APCLED=APCLFYE
- SET APCLOS="APCLOS"
- DO V
- +3 IF $GET(APCLMFY)=2
- SET APCLSD=APCL("FY WORKING DT")
- SET APCLED=APCLFYE
- SET APCLOS="APCLOS"
- DO V
- +4 DO SET^APCLOSUT
- +5 SET X1=APCLPYB
- SET X2=-1
- DO C^%DTC
- SET APCLSD=X_".9999"
- SET APCLED=APCLPYE
- SET APCLOS="APCLOSP"
- DO V
- +6 DO SET^APCLOSUT
- EOJ ;ENTRY POINT
- +1 KILL APCLSD,APCLODAT,APCLED,APCLVDFN,APCLVREC,APCLINJF,APCLALCH,APCLVLOC,APCL1,APCL2,APCLAP,APCLTYPE,APCLCAT,APCLVLOC,APCLCLNC,APCLCLIN,APCLDDFN,APCLDENT,APCLF,APCLPOV,APCLINJ,APCLAPC,G
- +2 KILL APCLX,APCLPROV,APCLY,APCLDISC,APCLPDFN,APCLA,APCLH,APCLD,APCLAMB,APCLEDAT,APCLL,APCLS,APCLC,APCLT,APCLP,APCLF,APCLH,APCLAPCD
- +3 QUIT
- V ;
- +1 SET %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,"
- SET APCLA=%_"""AMBPOV"",APCLPOV)"
- +2 SET %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,"
- SET APCLH=%_"""AMBAPC"",APCLAPC)"
- +3 SET %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,"
- SET APCLD=%_"""AMBINJCAUSE"",APCLINJ)"
- +4 SET %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,"
- SET APCLF=%_"""DENTPOV"",APCLDENT)"
- +5 SET %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,"
- SET APCLP=%_"""AMBPROV"",APCLDISC)"
- +6 SET %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,"
- SET APCLT=%_"""AMBTYPE"",APCLTYPE)"
- +7 SET %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,"
- SET APCLL=%_"""AMBLOC"",APCLVLOC)"
- +8 SET %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,"
- SET APCLS=%_"""AMBCAT"",APCLCAT)"
- +9 SET %="^XTMP("""_APCLOS_""",APCLJOB,APCLBTH,"
- SET APCLC=%_"""AMBCLIN"",APCLCLIN)"
- +10 SET APCLODAT=APCLSD
- FOR
- SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLODAT))
- IF APCLODAT=""!((APCLODAT\1)>APCLED)
- QUIT
- DO V1
- +11 QUIT
- V1 ;
- +1 SET APCLVDFN=""
- FOR
- SET APCLVDFN=$ORDER(^AUPNVSIT("B",APCLODAT,APCLVDFN))
- IF APCLVDFN'=+APCLVDFN
- QUIT
- IF $DATA(^AUPNVSIT(APCLVDFN,0))
- SET APCLVREC=^(0)
- DO PROC
- +2 QUIT
- PROC ;
- +1 KILL APCLINJF,APCLALCH
- +2 IF $$DEMO^APCLUTL($PIECE(APCLVREC,U,5),$GET(APCLDEMO))
- QUIT
- +3 IF '$PIECE(APCLVREC,U,9)
- QUIT
- +4 IF $PIECE(APCLVREC,U,11)
- QUIT
- +5 IF "DXEIH"[$PIECE(APCLVREC,U,7)
- QUIT
- +6 IF $PIECE(APCLVREC,U,3)=""
- QUIT
- +7 ;LAB/OHPRD CHANGED CV TO C FOR VA
- IF $DATA(^APCLCNTL(4,11,"B",$PIECE(APCLVREC,U,3)))
- QUIT
- +8 SET APCLVLOC=$PIECE(APCLVREC,U,6)
- IF APCLVLOC=""
- QUIT
- +9 IF '$DATA(^XTMP("APCLSU",APCLJOB,APCLBTH,APCLVLOC))
- QUIT
- +10 IF '$DATA(^AUPNVPOV("AD",APCLVDFN))
- QUIT
- +11 SET (APCL1,APCL2)=0
- FOR
- SET APCL2=$ORDER(^AUPNVPRV("AD",APCLVDFN,APCL2))
- IF APCL2=""
- QUIT
- IF $PIECE(^AUPNVPRV(APCL2,0),U,4)="P"
- SET APCL1=APCL1+1
- SET APCLAP=$PIECE(^(0),U)
- +12 IF APCL1=0
- QUIT
- +13 IF APCL1>1
- QUIT
- +14 IF $PIECE(APCLVREC,U,7)="C"
- SET ^("CHART REVIEWS")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"CHART REVIEWS")):(+^("CHART REVIEWS")+1),1:1)
- QUIT
- +15 SET ^("AMBVCOUNT")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"AMBVCOUNT")):(+^("AMBVCOUNT")+1),1:1)
- TYPE KILL ^UTILITY("DIQ1",$JOB)
- +1 KILL DIQ,DIC,DA,DR
- +2 SET DIC="^AUPNVSIT("
- SET DR=".03"
- SET DA=APCLVDFN
- SET DIQ(0)="E"
- DO EN^DIQ1
- KILL DIC,DA,DR,DIQ
- +3 SET APCLTYPE=^UTILITY("DIQ1",$JOB,9000010,APCLVDFN,.03,"E")
- +4 SET X=APCLT
- DO COUNT
- SC ;
- +1 KILL ^UTILITY("DIQ1",$JOB)
- +2 KILL DIQ,DIC,DA,DR
- +3 SET DIC="^AUPNVSIT("
- SET DR=".07"
- SET DA=APCLVDFN
- SET DIQ(0)="E"
- DO EN^DIQ1
- KILL DIC,DA,DR,DIQ
- +4 SET APCLCAT=^UTILITY("DIQ1",$JOB,9000010,APCLVDFN,.07,"E")
- +5 SET X=APCLS
- DO COUNT
- +6 KILL ^UTILITY("DIQ1",$JOB)
- LOC ;
- +1 SET X=APCLL
- DO COUNT
- CLINIC ;
- +1 SET APCLCLIN=$PIECE(APCLVREC,U,8)
- IF APCLCLIN=""
- SET APCLCLIN="NO CLINIC"
- SET APCLCLNC=""
- GOTO SETCLIN
- +2 SET APCLCLNC=$PIECE(^DIC(40.7,APCLCLIN,0),U,2)
- SET APCLCLIN=$PIECE(^DIC(40.7,APCLCLIN,0),U)
- SETCLIN ;
- +1 SET X=APCLC
- DO COUNT
- +2 IF APCLCLNC=30
- SET ^("ERCOUNT")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"ERCOUNT")):(+^("ERCOUNT")+1),1:1)
- +3 IF APCLCLNC=56
- DO DENTAL
- +4 ;
- PROV DO ^APCLOS41
- +1 QUIT
- DENTAL ;
- +1 SET ^("DENTVCOUNT")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"DENTVCOUNT")):(+^("DENTVCOUNT")+1),1:1)
- +2 SET APCLDDFN=0
- FOR
- SET APCLDDFN=$ORDER(^AUPNVDEN("AD",APCLVDFN,APCLDDFN))
- IF APCLDDFN'=+APCLDDFN
- QUIT
- IF $DATA(^AUPNVDEN(APCLDDFN,0))
- DO DENTAL1
- +3 QUIT
- DENTAL1 ;
- +1 SET APCLDENT=$PIECE(^AUPNVDEN(APCLDDFN,0),U)
- +2 SET X=APCLF
- DO COUNT
- +3 ;
- +4 IF $DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"DENTPAT",$PIECE(^AUPNVDEN(APCLDDFN,0),U,2)))
- QUIT
- +5 SET ^XTMP(APCLOS,APCLJOB,APCLBTH,"DENTPAT",$PIECE(^AUPNVDEN(APCLDDFN,0),U,2))=""
- +6 SET ^("DENTPATCOUNT")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"DENTPATCOUNT")):(+^("DENTPATCOUNT")+1),1:1)
- +7 QUIT
- COUNT ;
- +1 IF '$DATA(@X)
- SET @X=0
- +2 SET %=@X
- SET %=%+1
- SET @X=%
- +3 QUIT
