APCLPCT2 ; IHS/CMI/LAB - extension of APCLPCT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
S APCLBT=$H,APCLJOB=$J
K ^XTMP("APCLPCT",APCLJOB,APCLBT),^XTMP("APCLPCTR",APCLJOB,APCLBT),^XTMP("APCLPCT","APCLSU",APCLJOB,APCLBT)
D XTMP^APCLOSUT("APCLPCT","PCC REG PATS REPORT")
D XTMP^APCLOSUT("APCLPCTR","PCC REG PATS REPORT")
S APCLMAJ=$S(APCLSORT="C":"APCLCOMN",APCLSORT="T":"APCLTRI",1:"APCLSUR"),APCLMIN=$S(APCLSORT="C":"APCLTRI",1:"APCLCOMN")
S APCLSDI=9999999-APCLSD,APCLEDI=9999999-APCLED,APCLJ=0
I APCLFS="F" S ^XTMP("APCLPCT","APCLSU",APCLJOB,APCLBT,APCLSU)="" G PAT
LOC S APCLJ=$O(^AUTTLOC(APCLJ)) G:APCLJ'=+APCLJ PAT S:$P(^AUTTLOC(APCLJ,0),U,5)=APCLSU ^XTMP("APCLPCT","APCLSU",APCLJOB,APCLBT,APCLJ)="" G LOC
;
PAT S APCLDFN=0 F S APCLDFN=$O(^AUPNPAT(APCLDFN)) Q:APCLDFN'=+APCLDFN D C1
K APCLDFN,APCLV,APCLSDI,APCLEDI,APCLGOTA,APCLGOTB
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=1 Q
I '$D(^AUPNPAT(APCLDFN,11)),APCLIND=0 S APCLTRI="NO TRIBE ENTERED" G C11
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)
I '$D(^AUTTTRI(APCLTRI)),APCLIND=0 S APCLTRI="NO TRIBE ENTERED" G C11
Q:'$D(^AUTTTRI(APCLTRI))
S APCLTRIC=$P(^AUTTTRI(APCLTRI,0),U,2)
I APCLIND=1 Q:'(+APCLTRIC&(APCLTRIC<969!(APCLTRIC=997)))
S APCLTRI=$P(^AUTTTRI(APCLTRI,0),U)
C11 S (APCLJ,APCLSVJ)=0 F S APCLJ=$O(^AUPNPAT(APCLDFN,51,APCLJ)) Q:APCLJ'=+APCLJ S APCLSVJ=APCLJ
I 'APCLSVJ S APCLCOMN="NO COMMUNITY ENTERED *",APCLSUR="NO SU OF RESIDENCE" G HRN
S APCLCOMM=+$P(^AUPNPAT(APCLDFN,51,APCLSVJ,0),U,3) I 'APCLCOMM S APCLCOMN="NO COMMUNITY ENTERED *",APCLSUR="NO SU OF RESIDENCE *" G HRN
I '$D(^AUTTCOM(APCLCOMM,0)) S APCLCOMN="NO COMMUNITY ENTERED *",APCLSUR="NO SU OF RESIDENCE" G HRN
S APCLCOMN=$P(^AUTTCOM(APCLCOMM,0),U)
I $P(^AUTTCOM(APCLCOMM,0),"^",5)'=APCLSUF S APCLCOMN=APCLCOMN_" *"
S APCLSUR=$P(^AUTTCOM(APCLCOMM,0),U,5)
I APCLSUR="" S APCLSUR="NO SU OF RESIDENCE" G HRN
S APCLSUR=$S($D(^AUTTSU(APCLSUR)):$P(^AUTTSU(APCLSUR,0),U),1:"")
HRN S (APCLGOT1,APCLHRN)=0 F S APCLHRN=$O(^AUPNPAT(APCLDFN,41,APCLHRN)) Q:APCLHRN'=+APCLHRN!(APCLGOT1) D C2
Q
C2 I $D(^XTMP("APCLPCT","APCLSU",APCLJOB,APCLBT,$P(^AUPNPAT(APCLDFN,41,APCLHRN,0),U))) S APCLGOT1=1 D C3
Q
C3 I $D(^DPT(APCLDFN,.35)),$P(^(.35),U)]"" D C3SET G VISITS
C3ND S ^(@APCLMIN)=$S($D(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)):(+^(@APCLMIN)+1)_U_$P(^(@APCLMIN),U,2)_U_$P(^(@APCLMIN),U,3)_U_$P(^(@APCLMIN),U,4)_U_$P(^(@APCLMIN),U,5),1:"1^0^0^0^0")
;
VISITS ;
D ^APCLPCT3
Q
;
C3SET ;
S ^(@APCLMIN)=$S($D(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)):(+^(@APCLMIN)+0)_U_$P(^(@APCLMIN),U,2)_U_$P(^(@APCLMIN),U,3)_U_$P(^(@APCLMIN),U,4)_U_$P(^(@APCLMIN),U,5),1:"0^0^0^0^0")
Q
APCLPCT2 ; IHS/CMI/LAB - extension of APCLPCT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 SET APCLBT=$HOROLOG
SET APCLJOB=$JOB
+3 KILL ^XTMP("APCLPCT",APCLJOB,APCLBT),^XTMP("APCLPCTR",APCLJOB,APCLBT),^XTMP("APCLPCT","APCLSU",APCLJOB,APCLBT)
+4 DO XTMP^APCLOSUT("APCLPCT","PCC REG PATS REPORT")
+5 DO XTMP^APCLOSUT("APCLPCTR","PCC REG PATS REPORT")
+6 SET APCLMAJ=$SELECT(APCLSORT="C":"APCLCOMN",APCLSORT="T":"APCLTRI",1:"APCLSUR")
SET APCLMIN=$SELECT(APCLSORT="C":"APCLTRI",1:"APCLCOMN")
+7 SET APCLSDI=9999999-APCLSD
SET APCLEDI=9999999-APCLED
SET APCLJ=0
+8 IF APCLFS="F"
SET ^XTMP("APCLPCT","APCLSU",APCLJOB,APCLBT,APCLSU)=""
GOTO PAT
LOC SET APCLJ=$ORDER(^AUTTLOC(APCLJ))
IF APCLJ'=+APCLJ
GOTO PAT
IF $PIECE(^AUTTLOC(APCLJ,0),U,5)=APCLSU
SET ^XTMP("APCLPCT","APCLSU",APCLJOB,APCLBT,APCLJ)=""
GOTO LOC
+1 ;
PAT SET APCLDFN=0
FOR
SET APCLDFN=$ORDER(^AUPNPAT(APCLDFN))
IF APCLDFN'=+APCLDFN
QUIT
DO C1
+1 KILL APCLDFN,APCLV,APCLSDI,APCLEDI,APCLGOTA,APCLGOTB
+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=1
QUIT
+5 IF '$DATA(^AUPNPAT(APCLDFN,11))
IF APCLIND=0
SET APCLTRI="NO TRIBE ENTERED"
GOTO C11
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))
IF APCLIND=0
SET APCLTRI="NO TRIBE ENTERED"
GOTO C11
+4 IF '$DATA(^AUTTTRI(APCLTRI))
QUIT
+5 SET APCLTRIC=$PIECE(^AUTTTRI(APCLTRI,0),U,2)
+6 IF APCLIND=1
IF '(+APCLTRIC&(APCLTRIC<969!(APCLTRIC=997)))
QUIT
+7 SET APCLTRI=$PIECE(^AUTTTRI(APCLTRI,0),U)
C11 SET (APCLJ,APCLSVJ)=0
FOR
SET APCLJ=$ORDER(^AUPNPAT(APCLDFN,51,APCLJ))
IF APCLJ'=+APCLJ
QUIT
SET APCLSVJ=APCLJ
+1 IF 'APCLSVJ
SET APCLCOMN="NO COMMUNITY ENTERED *"
SET APCLSUR="NO SU OF RESIDENCE"
GOTO HRN
+2 SET APCLCOMM=+$PIECE(^AUPNPAT(APCLDFN,51,APCLSVJ,0),U,3)
IF 'APCLCOMM
SET APCLCOMN="NO COMMUNITY ENTERED *"
SET APCLSUR="NO SU OF RESIDENCE *"
GOTO HRN
+3 IF '$DATA(^AUTTCOM(APCLCOMM,0))
SET APCLCOMN="NO COMMUNITY ENTERED *"
SET APCLSUR="NO SU OF RESIDENCE"
GOTO HRN
+4 SET APCLCOMN=$PIECE(^AUTTCOM(APCLCOMM,0),U)
+5 IF $PIECE(^AUTTCOM(APCLCOMM,0),"^",5)'=APCLSUF
SET APCLCOMN=APCLCOMN_" *"
+6 SET APCLSUR=$PIECE(^AUTTCOM(APCLCOMM,0),U,5)
+7 IF APCLSUR=""
SET APCLSUR="NO SU OF RESIDENCE"
GOTO HRN
+8 SET APCLSUR=$SELECT($DATA(^AUTTSU(APCLSUR)):$PIECE(^AUTTSU(APCLSUR,0),U),1:"")
HRN SET (APCLGOT1,APCLHRN)=0
FOR
SET APCLHRN=$ORDER(^AUPNPAT(APCLDFN,41,APCLHRN))
IF APCLHRN'=+APCLHRN!(APCLGOT1)
QUIT
DO C2
+1 QUIT
C2 IF $DATA(^XTMP("APCLPCT","APCLSU",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)]""
DO C3SET
GOTO VISITS
C3ND SET ^(@APCLMIN)=$SELECT($DATA(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)):(+^(@APCLMIN)+1)_U_$PIECE(^(@APCLMIN),U,2)_U_$PIECE(^(@APCLMIN),U,3)_U_$PIECE(^(@APCLMIN),U,4)_U_$PIECE(^(@APCLMIN),U,5),1:"1^0^0^0^0")
+1 ;
VISITS ;
+1 DO ^APCLPCT3
+2 QUIT
+3 ;
C3SET ;
+1 SET ^(@APCLMIN)=$SELECT($DATA(^XTMP("APCLPCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)):(+^(@APCLMIN)+0)_U_$PIECE(^(@APCLMIN),U,2)_U_$PIECE(^(@APCLMIN),U,3)_U_$PIECE(^(@APCLMIN),U,4)_U_$PIECE(^(@APCLMIN),U,5),1:"0^0^0^0^0")
+2 QUIT
