- 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
