- 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
