APCLACC2 ; IHS/CMI/LAB - process active user report ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;IHS/CMI/LAB - added template creation
;
S APCLJOB=$J,APCLBT=$H
K ^XTMP("APCLACC",APCLJOB,APCLBT),^XTMP("APCLACCR",APCLJOB,APCLBT),^XTMP("APCLACC SU",APCLJOB,APCLBT)
D XTMP^APCLOSUT("APCLACC","PCC ACTIVE USERS REPORT")
D XTMP^APCLOSUT("APCLACCR","PCC ACTIVE USERS REPORT")
D XTMP^APCLOSUT("APCLACC SU","PCC ACTIVE USERS REPORT")
S APCLMAJ=$S(APCLSORT="C":"APCLCOMN",APCLSORT="T":"APCLTRI",1:"APCLSUR")
S APCLMIN=$S(APCLSORT="C":"APCLTRI",1:"APCLCOMN")
X S X1=APCLFYE,X2=1 D C^%DTC S APCLFYB=($E(X,1,3)-3)_$E(X,4,7) S Y=APCLFYB D DD^%DT S APCLFYBY=Y
;S X1=APCLFYE,X2=$S(+$E(APCLFYE,4,7)>930:-1096,1:-1461) D C^%DTC
;S APCLFYB=$E(X,1,3)_"1001" S Y=APCLFYB D DD^%DT S APCLFYBY=Y
K X,X1,X2,Y
S APCLJ=0
I APCLFS="F" S X=0 F S X=$O(APCLSU(X)) Q:X'=+X S ^XTMP("APCLACC SU",APCLJOB,APCLBT,X)=""
I APCLFS="F" G PAT
LOC S X=0 F S X=$O(^AUTTLOC(X)) Q:X'=+X I $P(^AUTTLOC(X,0),U,5),$D(APCLSU($P(^AUTTLOC(X,0),U,5))) S ^XTMP("APCLACC SU",APCLJOB,APCLBT,X)=""
PAT S APCLDFN=0 F I=0:0 S APCLDFN=$O(^AUPNPAT(APCLDFN)) Q:APCLDFN'=+APCLDFN D C1
K APCLDFN,APCLV,APCLFYBI,APCLFYEI,APCLGOTA
S APCLET=$H
Q
C1 ;
Q:'$D(^DPT(APCLDFN,0))
Q:$P(^DPT(APCLDFN,0),U,19)]""
Q:$$DEMO^APCLUTL(APCLDFN,$G(APCLDEMO))
I '$D(^AUPNPAT(APCLDFN,11)),APCLIND=0 S APCLTRI="NO TRIBE ENTERED" G C11
Q:'$D(^AUPNPAT(APCLDFN,11))
C1A I $P(^AUPNPAT(APCLDFN,11),U,8)="",APCLIND=0 S APCLTRI="NO TRIBE ENTERED" G C11
Q:$P(^AUPNPAT(APCLDFN,11),U,8)=""
S APCLTRI=$P(^AUPNPAT(APCLDFN,11),U,8)
Q:'$D(^AUTTTRI(APCLTRI))
S APCLTRIC=$P(^AUTTTRI(APCLTRI,0),U,2)
I APCLIND=1 Q:'(+APCLTRIC&(APCLTRIC<969!(APCLTRIC=997)!(APCLTRIC=999)))
S APCLTRI=$P(^AUTTTRI(APCLTRI,0),U)
C11 S (APCLJ,APCLSVJ)=0 F J=0:0 S APCLJ=$O(^AUPNPAT(APCLDFN,51,APCLJ)) Q:APCLJ'=+APCLJ S APCLSVJ=APCLJ
I 'APCLSVJ,APCLSSUR=0 S APCLCOMN="NO COMMUNITY ENTERED *",APCLSUR="NO SU OF RESIDENCE" G HRN
Q:'APCLSVJ
S APCLCOMM=+$P(^AUPNPAT(APCLDFN,51,APCLSVJ,0),U,3) I 'APCLCOMM,APCLSSUR=0 S APCLCOMN="NO COMMUNITY ENTERED *",APCLSUR="NO SU OF RESIDENCE" G HRN
Q:'APCLCOMM
Q:'$D(^AUTTCOM(APCLCOMM,0))
S APCLCOMN=$P(^AUTTCOM(APCLCOMM,0),U)
I '$P(^AUTTCOM(APCLCOMM,0),U,5),APCLSSUR=0 S APCLCOMN=APCLCOMN_" *" G SETSUR
I '$P(^AUTTCOM(APCLCOMM,0),U,5),APCLSSUR Q ;no su and want only people living in that service unit
I '$D(APCLSUF($P(^AUTTCOM(APCLCOMM,0),U,5))),APCLSSUR=0 S APCLCOMN=APCLCOMN_" *" G SETSUR
Q:'$D(APCLSUF($P(^AUTTCOM(APCLCOMM,0),U,5)))
SETSUR S APCLSUR=$P(^AUTTCOM(APCLCOMM,0),U,5)
I APCLSUR="" S APCLSUR="NO SU OF RESIDENCE" G HRN
S APCLSUR=$P(^AUTTSU(APCLSUR,0),U)
HRN S (APCLGOT1,APCLHRN)=0 F J=0:0 S APCLHRN=$O(^AUPNPAT(APCLDFN,41,APCLHRN)) Q:APCLHRN'=+APCLHRN!(APCLGOT1) D C2
Q
C2 I $D(^XTMP("APCLACC SU",APCLJOB,APCLBT,$P(^AUPNPAT(APCLDFN,41,APCLHRN,0),U))) S APCLGOT1=1 D C3
Q
C3 I $D(^DPT(APCLDFN,.35)),$P(^(.35),U)]"",APCLRPTT'="T" S ^(@APCLMIN)=$S($D(^XTMP("APCLACC",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)):(+^(@APCLMIN)+0)_U_$P(^(@APCLMIN),U,2),1:"0^0") G VISITS
C3ND I APCLRPTT'="T" S ^(@APCLMIN)=$S($D(^XTMP("APCLACC",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)):(+^(@APCLMIN)+1)_U_$P(^(@APCLMIN),U,2),1:"1^0")
VISITS ;
S APCLFYBI=9999999-APCLFYB,APCLFYEI=9999999-APCLFYE
K APCLGOTA,APCLSKIP
S APCLV=0 F S APCLV=$O(^AUPNVSIT("AA",APCLDFN,APCLV)) Q:APCLV'=+APCLV!($D(APCLGOTA))!($P(APCLV,".")>APCLFYBI) S APCLVD=$P(APCLV,".") D PROC
Q
PROC ;
S APCLVDFN=0 F S APCLVDFN=$O(^AUPNVSIT("AA",APCLDFN,APCLV,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN D ACTIVE
Q
ACTIVE ;determine if patient was seen in FYs
;home clinic, telephone and employee health clinics ignored
Q:$D(APCLGOTA)
Q:APCLVD>APCLFYBI
Q:APCLVD<APCLFYEI
Q:$P(^AUPNVSIT(APCLVDFN,0),U,11)
Q:'$P(^AUPNVSIT(APCLVDFN,0),U,9)
Q:"DXECT"[$P(^AUPNVSIT(APCLVDFN,0),U,7)
S %=$$CLINIC^APCLV(APCLVDFN,"C") I %=11!(%=68)!(%=51) Q
;Q:"V"[$P(^AUPNVSIT(APCLVDFN,0),U,3) ;LAB/TUCSON COMMENTED OUT FOR VA
Q:'$D(^AUPNVPOV("AD",APCLVDFN))
Q:'$D(^AUPNVPRV("AD",APCLVDFN))
S APCLGOTA="" I APCLRPTT'="T" S $P(^XTMP("APCLACC",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,2)=$P(^XTMP("APCLACC",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,2)+1
I APCLRPTT="T" S ^XTMP("APCLACC",APCLJOB,APCLBT,"TEMPLATE PATIENTS",APCLDFN)=""
Q
;
;
APCLACC2 ; IHS/CMI/LAB - process active user report ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;IHS/CMI/LAB - added template creation
+3 ;
+4 SET APCLJOB=$JOB
SET APCLBT=$HOROLOG
+5 KILL ^XTMP("APCLACC",APCLJOB,APCLBT),^XTMP("APCLACCR",APCLJOB,APCLBT),^XTMP("APCLACC SU",APCLJOB,APCLBT)
+6 DO XTMP^APCLOSUT("APCLACC","PCC ACTIVE USERS REPORT")
+7 DO XTMP^APCLOSUT("APCLACCR","PCC ACTIVE USERS REPORT")
+8 DO XTMP^APCLOSUT("APCLACC SU","PCC ACTIVE USERS REPORT")
+9 SET APCLMAJ=$SELECT(APCLSORT="C":"APCLCOMN",APCLSORT="T":"APCLTRI",1:"APCLSUR")
+10 SET APCLMIN=$SELECT(APCLSORT="C":"APCLTRI",1:"APCLCOMN")
X SET X1=APCLFYE
SET X2=1
DO C^%DTC
SET APCLFYB=($EXTRACT(X,1,3)-3)_$EXTRACT(X,4,7)
SET Y=APCLFYB
DO DD^%DT
SET APCLFYBY=Y
+1 ;S X1=APCLFYE,X2=$S(+$E(APCLFYE,4,7)>930:-1096,1:-1461) D C^%DTC
+2 ;S APCLFYB=$E(X,1,3)_"1001" S Y=APCLFYB D DD^%DT S APCLFYBY=Y
+3 KILL X,X1,X2,Y
+4 SET APCLJ=0
+5 IF APCLFS="F"
SET X=0
FOR
SET X=$ORDER(APCLSU(X))
IF X'=+X
QUIT
SET ^XTMP("APCLACC SU",APCLJOB,APCLBT,X)=""
+6 IF APCLFS="F"
GOTO PAT
LOC SET X=0
FOR
SET X=$ORDER(^AUTTLOC(X))
IF X'=+X
QUIT
IF $PIECE(^AUTTLOC(X,0),U,5)
IF $DATA(APCLSU($PIECE(^AUTTLOC(X,0),U,5)))
SET ^XTMP("APCLACC SU",APCLJOB,APCLBT,X)=""
PAT SET APCLDFN=0
FOR I=0:0
SET APCLDFN=$ORDER(^AUPNPAT(APCLDFN))
IF APCLDFN'=+APCLDFN
QUIT
DO C1
+1 KILL APCLDFN,APCLV,APCLFYBI,APCLFYEI,APCLGOTA
+2 SET APCLET=$HOROLOG
+3 QUIT
C1 ;
+1 IF '$DATA(^DPT(APCLDFN,0))
QUIT
+2 IF $PIECE(^DPT(APCLDFN,0),U,19)]""
QUIT
+3 IF $$DEMO^APCLUTL(APCLDFN,$GET(APCLDEMO))
QUIT
+4 IF '$DATA(^AUPNPAT(APCLDFN,11))
IF APCLIND=0
SET APCLTRI="NO TRIBE ENTERED"
GOTO C11
+5 IF '$DATA(^AUPNPAT(APCLDFN,11))
QUIT
C1A IF $PIECE(^AUPNPAT(APCLDFN,11),U,8)=""
IF APCLIND=0
SET APCLTRI="NO TRIBE ENTERED"
GOTO C11
+1 IF $PIECE(^AUPNPAT(APCLDFN,11),U,8)=""
QUIT
+2 SET APCLTRI=$PIECE(^AUPNPAT(APCLDFN,11),U,8)
+3 IF '$DATA(^AUTTTRI(APCLTRI))
QUIT
+4 SET APCLTRIC=$PIECE(^AUTTTRI(APCLTRI,0),U,2)
+5 IF APCLIND=1
IF '(+APCLTRIC&(APCLTRIC<969!(APCLTRIC=997)!(APCLTRIC=999)))
QUIT
+6 SET APCLTRI=$PIECE(^AUTTTRI(APCLTRI,0),U)
C11 SET (APCLJ,APCLSVJ)=0
FOR J=0:0
SET APCLJ=$ORDER(^AUPNPAT(APCLDFN,51,APCLJ))
IF APCLJ'=+APCLJ
QUIT
SET APCLSVJ=APCLJ
+1 IF 'APCLSVJ
IF APCLSSUR=0
SET APCLCOMN="NO COMMUNITY ENTERED *"
SET APCLSUR="NO SU OF RESIDENCE"
GOTO HRN
+2 IF 'APCLSVJ
QUIT
+3 SET APCLCOMM=+$PIECE(^AUPNPAT(APCLDFN,51,APCLSVJ,0),U,3)
IF 'APCLCOMM
IF APCLSSUR=0
SET APCLCOMN="NO COMMUNITY ENTERED *"
SET APCLSUR="NO SU OF RESIDENCE"
GOTO HRN
+4 IF 'APCLCOMM
QUIT
+5 IF '$DATA(^AUTTCOM(APCLCOMM,0))
QUIT
+6 SET APCLCOMN=$PIECE(^AUTTCOM(APCLCOMM,0),U)
+7 IF '$PIECE(^AUTTCOM(APCLCOMM,0),U,5)
IF APCLSSUR=0
SET APCLCOMN=APCLCOMN_" *"
GOTO SETSUR
+8 ;no su and want only people living in that service unit
IF '$PIECE(^AUTTCOM(APCLCOMM,0),U,5)
IF APCLSSUR
QUIT
+9 IF '$DATA(APCLSUF($PIECE(^AUTTCOM(APCLCOMM,0),U,5)))
IF APCLSSUR=0
SET APCLCOMN=APCLCOMN_" *"
GOTO SETSUR
+10 IF '$DATA(APCLSUF($PIECE(^AUTTCOM(APCLCOMM,0),U,5)))
QUIT
SETSUR SET APCLSUR=$PIECE(^AUTTCOM(APCLCOMM,0),U,5)
+1 IF APCLSUR=""
SET APCLSUR="NO SU OF RESIDENCE"
GOTO HRN
+2 SET APCLSUR=$PIECE(^AUTTSU(APCLSUR,0),U)
HRN SET (APCLGOT1,APCLHRN)=0
FOR J=0:0
SET APCLHRN=$ORDER(^AUPNPAT(APCLDFN,41,APCLHRN))
IF APCLHRN'=+APCLHRN!(APCLGOT1)
QUIT
DO C2
+1 QUIT
C2 IF $DATA(^XTMP("APCLACC SU",APCLJOB,APCLBT,$PIECE(^AUPNPAT(APCLDFN,41,APCLHRN,0),U)))
SET APCLGOT1=1
DO C3
+1 QUIT
C3 IF $DATA(^DPT(APCLDFN,.35))
IF $PIECE(^(.35),U)]""
IF APCLRPTT'="T"
SET ^(@APCLMIN)=$SELECT($DATA(^XTMP("APCLACC",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)):(+^(@APCLMIN)+0)_U_$PIECE(^(@APCLMIN),U,2),1:"0^0")
GOTO VISITS
C3ND IF APCLRPTT'="T"
SET ^(@APCLMIN)=$SELECT($DATA(^XTMP("APCLACC",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)):(+^(@APCLMIN)+1)_U_$PIECE(^(@APCLMIN),U,2),1:"1^0")
VISITS ;
+1 SET APCLFYBI=9999999-APCLFYB
SET APCLFYEI=9999999-APCLFYE
+2 KILL APCLGOTA,APCLSKIP
+3 SET APCLV=0
FOR
SET APCLV=$ORDER(^AUPNVSIT("AA",APCLDFN,APCLV))
IF APCLV'=+APCLV!($DATA(APCLGOTA))!($PIECE(APCLV,".")>APCLFYBI)
QUIT
SET APCLVD=$PIECE(APCLV,".")
DO PROC
+4 QUIT
PROC ;
+1 SET APCLVDFN=0
FOR
SET APCLVDFN=$ORDER(^AUPNVSIT("AA",APCLDFN,APCLV,APCLVDFN))
IF APCLVDFN'=+APCLVDFN
QUIT
DO ACTIVE
+2 QUIT
ACTIVE ;determine if patient was seen in FYs
+1 ;home clinic, telephone and employee health clinics ignored
+2 IF $DATA(APCLGOTA)
QUIT
+3 IF APCLVD>APCLFYBI
QUIT
+4 IF APCLVD<APCLFYEI
QUIT
+5 IF $PIECE(^AUPNVSIT(APCLVDFN,0),U,11)
QUIT
+6 IF '$PIECE(^AUPNVSIT(APCLVDFN,0),U,9)
QUIT
+7 IF "DXECT"[$PIECE(^AUPNVSIT(APCLVDFN,0),U,7)
QUIT
+8 SET %=$$CLINIC^APCLV(APCLVDFN,"C")
IF %=11!(%=68)!(%=51)
QUIT
+9 ;Q:"V"[$P(^AUPNVSIT(APCLVDFN,0),U,3) ;LAB/TUCSON COMMENTED OUT FOR VA
+10 IF '$DATA(^AUPNVPOV("AD",APCLVDFN))
QUIT
+11 IF '$DATA(^AUPNVPRV("AD",APCLVDFN))
QUIT
+12 SET APCLGOTA=""
IF APCLRPTT'="T"
SET $PIECE(^XTMP("APCLACC",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,2)=$PIECE(^XTMP("APCLACC",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,2)+1
+13 IF APCLRPTT="T"
SET ^XTMP("APCLACC",APCLJOB,APCLBT,"TEMPLATE PATIENTS",APCLDFN)=""
+14 QUIT
+15 ;
+16 ;
