APCLHCT2 ; IHS/CMI/LAB - extension of APCLHCT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
S APCLSUF=$P(^AUTTLOC(APCLLOC,0),U,5)
S APCLBT=$H,APCLJOB=$J
K ^XTMP("APCLHCT",APCLJOB,APCLBT),^XTMP("APCLHCTR",APCLJOB,APCLBT),^XTMP("APCLHCT","APCLSU",APCLJOB,APCLBT)
D XTMP^APCLOSUT("APCLHCT","PCC REG PATS REPORT")
D XTMP^APCLOSUT("APCLHCTR","PCC REG PATS REPORT")
S APCLMAJ=$S(APCLSORT="C":"APCLCOMN",APCLSORT="T":"APCLTRI",1:"APCLSUR"),APCLMIN=$S(APCLSORT="C":"APCLTRI",1:"APCLCOMN")
;
S APCLSD=$$FMADD^XLFDT(APCLSD,-1)_".9999"
F S APCLSD=$O(^AUPNVINP("B",APCLSD)) Q:APCLSD'=+APCLSD!($P(APCLSD,".")>APCLED) D
.S APCLIDFN=0 F S APCLIDFN=$O(^AUPNVINP("B",APCLSD,APCLIDFN)) Q:APCLIDFN'=+APCLIDFN D C1
.Q
Q
C1 ;
Q:'$D(^AUPNVINP(APCLIDFN,0))
S V=$P(^AUPNVINP(APCLIDFN,0),U,3)
Q:'$D(^AUPNVSIT(V,0))
Q:$P(^AUPNVSIT(V,0),U,6)'=APCLLOC
S DFN=$P(^AUPNVINP(APCLIDFN,0),U,2)
Q:'DFN
Q:$P(^DPT(DFN,0),U,19)]""
Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
I '$D(^AUPNPAT(DFN,11)),APCLIND=1 Q
I '$D(^AUPNPAT(DFN,11)),APCLIND=0 S APCLTRI="NO TRIBE ENTERED" G C11
C1A I $P(^AUPNPAT(DFN,11),U,8)="",APCLIND=0 S APCLTRI="NO TRIBE ENTERED" G C11
Q:$P(^AUPNPAT(DFN,11),U,8)=""
S APCLTRI=$P(^AUPNPAT(DFN,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(DFN,51,APCLJ)) Q:APCLJ'=+APCLJ S APCLSVJ=APCLJ
I 'APCLSVJ S APCLCOMN="NO COMMUNITY ENTERED *",APCLSUR="NO SU OF RESIDENCE" G C2
S APCLCOMM=+$P(^AUPNPAT(DFN,51,APCLSVJ,0),U,3) I 'APCLCOMM S APCLCOMN="NO COMMUNITY ENTERED *",APCLSUR="NO SU OF RESIDENCE *" G C2
I '$D(^AUTTCOM(APCLCOMM,0)) S APCLCOMN="NO COMMUNITY ENTERED *",APCLSUR="NO SU OF RESIDENCE" G C2
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 C2
S APCLSUR=$S($D(^AUTTSU(APCLSUR)):$P(^AUTTSU(APCLSUR,0),U),1:"")
C2 ;
;do counts
;set newborn cnt and days if 07
S X=$P(^AUPNVINP(APCLIDFN,0),U,4)
Q:'X
S X=$P($G(^DIC(45.7,X,9999999)),U)
Q:X=""
I X="07" D Q
.S $P(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,3)=$P($G(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,3)+1
.S $P(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,4)=$P($G(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,4)+$$VAL^XBDIQ1(9000010.02,APCLIDFN,.019)
.D TX3P
S $P(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,1)=$P($G(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,1)+1
S $P(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,2)=$P($G(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,2)+$$VAL^XBDIQ1(9000010.02,APCLIDFN,.019)
D TX3P
Q
TX3P ;
S V=$P(^AUPNVINP(APCLIDFN,0),U,3)
S X=$$ADMTYPE^APCLV(V,"C") I X=2!(X=3) S $P(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,5)=$P($G(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,5)+1
I $$MCR^AUPNPAT($P(^AUPNVINP(APCLIDFN,0),U,2),$P($P(^AUPNVSIT(V,0),U),".")) D
.S $P(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,6)=$P($G(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,6)+1
I $$MCD^AUPNPAT($P(^AUPNVINP(APCLIDFN,0),U,2),$P($P(^AUPNVSIT(V,0),U),".")) D
.S $P(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,7)=$P($G(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,7)+1
I $$PI^AUPNPAT($P(^AUPNVINP(APCLIDFN,0),U,2),$P($P(^AUPNVSIT(V,0),U),".")) D
.S $P(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,8)=$P($G(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,8)+1
Q
APCLHCT2 ; IHS/CMI/LAB - extension of APCLHCT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 SET APCLSUF=$PIECE(^AUTTLOC(APCLLOC,0),U,5)
+3 SET APCLBT=$HOROLOG
SET APCLJOB=$JOB
+4 KILL ^XTMP("APCLHCT",APCLJOB,APCLBT),^XTMP("APCLHCTR",APCLJOB,APCLBT),^XTMP("APCLHCT","APCLSU",APCLJOB,APCLBT)
+5 DO XTMP^APCLOSUT("APCLHCT","PCC REG PATS REPORT")
+6 DO XTMP^APCLOSUT("APCLHCTR","PCC REG PATS REPORT")
+7 SET APCLMAJ=$SELECT(APCLSORT="C":"APCLCOMN",APCLSORT="T":"APCLTRI",1:"APCLSUR")
SET APCLMIN=$SELECT(APCLSORT="C":"APCLTRI",1:"APCLCOMN")
+8 ;
+9 SET APCLSD=$$FMADD^XLFDT(APCLSD,-1)_".9999"
+10 FOR
SET APCLSD=$ORDER(^AUPNVINP("B",APCLSD))
IF APCLSD'=+APCLSD!($PIECE(APCLSD,".")>APCLED)
QUIT
Begin DoDot:1
+11 SET APCLIDFN=0
FOR
SET APCLIDFN=$ORDER(^AUPNVINP("B",APCLSD,APCLIDFN))
IF APCLIDFN'=+APCLIDFN
QUIT
DO C1
+12 QUIT
End DoDot:1
+13 QUIT
C1 ;
+1 IF '$DATA(^AUPNVINP(APCLIDFN,0))
QUIT
+2 SET V=$PIECE(^AUPNVINP(APCLIDFN,0),U,3)
+3 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+4 IF $PIECE(^AUPNVSIT(V,0),U,6)'=APCLLOC
QUIT
+5 SET DFN=$PIECE(^AUPNVINP(APCLIDFN,0),U,2)
+6 IF 'DFN
QUIT
+7 IF $PIECE(^DPT(DFN,0),U,19)]""
QUIT
+8 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+9 IF '$DATA(^AUPNPAT(DFN,11))
IF APCLIND=1
QUIT
+10 IF '$DATA(^AUPNPAT(DFN,11))
IF APCLIND=0
SET APCLTRI="NO TRIBE ENTERED"
GOTO C11
C1A IF $PIECE(^AUPNPAT(DFN,11),U,8)=""
IF APCLIND=0
SET APCLTRI="NO TRIBE ENTERED"
GOTO C11
+1 IF $PIECE(^AUPNPAT(DFN,11),U,8)=""
QUIT
+2 SET APCLTRI=$PIECE(^AUPNPAT(DFN,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(DFN,51,APCLJ))
IF APCLJ'=+APCLJ
QUIT
SET APCLSVJ=APCLJ
+1 IF 'APCLSVJ
SET APCLCOMN="NO COMMUNITY ENTERED *"
SET APCLSUR="NO SU OF RESIDENCE"
GOTO C2
+2 SET APCLCOMM=+$PIECE(^AUPNPAT(DFN,51,APCLSVJ,0),U,3)
IF 'APCLCOMM
SET APCLCOMN="NO COMMUNITY ENTERED *"
SET APCLSUR="NO SU OF RESIDENCE *"
GOTO C2
+3 IF '$DATA(^AUTTCOM(APCLCOMM,0))
SET APCLCOMN="NO COMMUNITY ENTERED *"
SET APCLSUR="NO SU OF RESIDENCE"
GOTO C2
+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 C2
+8 SET APCLSUR=$SELECT($DATA(^AUTTSU(APCLSUR)):$PIECE(^AUTTSU(APCLSUR,0),U),1:"")
C2 ;
+1 ;do counts
+2 ;set newborn cnt and days if 07
+3 SET X=$PIECE(^AUPNVINP(APCLIDFN,0),U,4)
+4 IF 'X
QUIT
+5 SET X=$PIECE($GET(^DIC(45.7,X,9999999)),U)
+6 IF X=""
QUIT
+7 IF X="07"
Begin DoDot:1
+8 SET $PIECE(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,3)=$PIECE($GET(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,3)+1
+9 SET $PIECE(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,4)=$PIECE($GET(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,4)+$$VAL^XBDIQ1(9000010.02,APCLIDFN,.019)
+10 DO TX3P
End DoDot:1
QUIT
+11 SET $PIECE(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,1)=$PIECE($GET(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,1)+1
+12 SET $PIECE(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,2)=$PIECE($GET(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,2)+$$VAL^XBDIQ1(9000010.02,APCLIDFN,.019)
+13 DO TX3P
+14 QUIT
TX3P ;
+1 SET V=$PIECE(^AUPNVINP(APCLIDFN,0),U,3)
+2 SET X=$$ADMTYPE^APCLV(V,"C")
IF X=2!(X=3)
SET $PIECE(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,5)=$PIECE($GET(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,5)+1
+3 IF $$MCR^AUPNPAT($PIECE(^AUPNVINP(APCLIDFN,0),U,2),$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
Begin DoDot:1
+4 SET $PIECE(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,6)=$PIECE($GET(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,6)+1
End DoDot:1
+5 IF $$MCD^AUPNPAT($PIECE(^AUPNVINP(APCLIDFN,0),U,2),$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
Begin DoDot:1
+6 SET $PIECE(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,7)=$PIECE($GET(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,7)+1
End DoDot:1
+7 IF $$PI^AUPNPAT($PIECE(^AUPNVINP(APCLIDFN,0),U,2),$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
Begin DoDot:1
+8 SET $PIECE(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN),U,8)=$PIECE($GET(^XTMP("APCLHCT",APCLJOB,APCLBT,@APCLMAJ,@APCLMIN)),U,8)+1
End DoDot:1
+9 QUIT
