- 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 ;
