APCLOS2.m

APCLOS2 ; IHS/CMI/LAB - calculate ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

POP ;Population and third party sections of operational sum

PAT S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  K DOD,DOB D PROC

 K DFN,APCLV,APCLFYBI,APCLFYEI,APCLGOTA,DOB,DOD,APCLGOT1,APCLHRN,APCLBDAT,APCLEDAT,APCLMCR,APCLACE,APCLGOT,APCLMDFN,APCLVAL,APCLNDFN,APCLR

 Q

PROC ;

 Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))

 D LIVREG

 Q:'APCLGOT1

 D NEWREG

 D DEATHS

 D BIRTHS

 D THIRD^APCLOS21

 Q

LIVREG S (APCLGOT1,APCLHRN)=0 F J=0:0 S APCLHRN=$O(^AUPNPAT(DFN,41,APCLHRN)) Q:APCLHRN'=+APCLHRN!(APCLGOT1)  D LR2

 Q

LR2 ;

 Q:'$D(^AUPNPAT(DFN,0))

 Q:'$D(^XTMP("APCLSU",APCLJOB,APCLBTH,$P(^AUPNPAT(DFN,41,APCLHRN,0),U)))

 Q:$P(^DPT(DFN,0),U,19)]""

 Q:$P(^AUPNPAT(DFN,0),U,2)>APCLFYE

 I $D(^DPT(DFN,.35)),$P(^DPT(DFN,.35),U)]"" S DOD=$P(^DPT(DFN,.35),U)

 D LR3P

 S APCLGOT1=1

 I $D(DOD),DOD'>APCLFYE Q

 S ^("LIVREG")=$S($D(^XTMP("APCLOS",APCLJOB,APCLBTH,"LIVREG")):(+^("LIVREG")+1),1:1)

 Q

 ;

 ;

LR3P ;

 Q:$P(^AUPNPAT(DFN,0),U,2)>APCLPYE

 I $D(DOD),DOD'>APCLPYE Q

 S ^("LIVREG")=$S($D(^XTMP("APCLOSP",APCLJOB,APCLBTH,"LIVREG")):(+^("LIVREG")+1),1:1)

 Q

BIRTHS ;

 S DOB=$P(^DPT(DFN,0),U,3)

 Q:DOB=""

 I DOB'<APCLFYB,DOB'>APCLFYE S ^("BIRTHS")=$S($D(^XTMP("APCLOS",APCLJOB,APCLBTH,"BIRTHS")):(+^("BIRTHS")+1),1:1)

 I DOB'<APCLPYB,DOB'>APCLPYE S ^("BIRTHS")=$S($D(^XTMP("APCLOSP",APCLJOB,APCLBTH,"BIRTHS")):(+^("BIRTHS")+1),1:1)

 Q

DEATHS ;

 Q:'$D(DOD)

 I DOD'<APCLFYB,DOD'>APCLFYE S ^("DEATHS")=$S($D(^XTMP("APCLOS",APCLJOB,APCLBTH,"DEATHS")):(+^("DEATHS")+1),1:1)

 I DOD'<APCLPYB,DOD'>APCLPYE S ^("DEATHS")=$S($D(^XTMP("APCLOSP",APCLJOB,APCLBTH,"DEATHS")):(+^("DEATHS")+1),1:1)

 Q

NEWREG ;

 S APCLOS="APCLOS" S APCLBDAT=APCLFYB,APCLEDAT=APCLFYE D NEWREG1

 S APCLOS="APCLOSP" S APCLBDAT=APCLPYB,APCLEDAT=APCLPYE D NEWREG1

 Q

NEWREG1 ;

 I $P(^AUPNPAT(DFN,0),U,2)<APCLBDAT!($P(^AUPNPAT(DFN,0),U,2)>APCLEDAT) Q

 S ^("NEWREG")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"NEWREG")):(+^("NEWREG")+1),1:1)

 ;

 ;

 Q

APCLOS2   ; IHS/CMI/LAB - calculate ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

POP       ;Population and third party sections of operational sum

PAT        SET DFN=0

           FOR 

               SET DFN=$ORDER(^AUPNPAT(DFN))

               IF DFN'=+DFN

                   QUIT 

               KILL DOD,DOB

               DO PROC

 +1        KILL DFN,APCLV,APCLFYBI,APCLFYEI,APCLGOTA,DOB,DOD,APCLGOT1,APCLHRN,APCLBDAT,APCLEDAT,APCLMCR,APCLACE,APCLGOT,APCLMDFN,APCLVAL,APCLNDFN,APCLR

 +2        QUIT 

PROC      ;

 +1        IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))

               QUIT 

 +2        DO LIVREG

 +3        IF 'APCLGOT1

               QUIT 

 +4        DO NEWREG

 +5        DO DEATHS

 +6        DO BIRTHS

 +7        DO THIRD^APCLOS21

 +8        QUIT 

LIVREG     SET (APCLGOT1,APCLHRN)=0

           FOR J=0:0

               SET APCLHRN=$ORDER(^AUPNPAT(DFN,41,APCLHRN))

               IF APCLHRN'=+APCLHRN!(APCLGOT1)

                   QUIT 

               DO LR2

 +1        QUIT 

LR2       ;

 +1        IF '$DATA(^AUPNPAT(DFN,0))

               QUIT 

 +2        IF '$DATA(^XTMP("APCLSU",APCLJOB,APCLBTH,$PIECE(^AUPNPAT(DFN,41,APCLHRN,0),U)))

               QUIT 

 +3        IF $PIECE(^DPT(DFN,0),U,19)]""

               QUIT 

 +4        IF $PIECE(^AUPNPAT(DFN,0),U,2)>APCLFYE

               QUIT 

 +5        IF $DATA(^DPT(DFN,.35))

               IF $PIECE(^DPT(DFN,.35),U)]""

                   SET DOD=$PIECE(^DPT(DFN,.35),U)

 +6        DO LR3P

 +7        SET APCLGOT1=1

 +8        IF $DATA(DOD)

               IF DOD'>APCLFYE

                   QUIT 

 +9        SET ^("LIVREG")=$SELECT($DATA(^XTMP("APCLOS",APCLJOB,APCLBTH,"LIVREG")):(+^("LIVREG")+1),1:1)

 +10       QUIT 

 +11      ;

 +12      ;

LR3P      ;

 +1        IF $PIECE(^AUPNPAT(DFN,0),U,2)>APCLPYE

               QUIT 

 +2        IF $DATA(DOD)

               IF DOD'>APCLPYE

                   QUIT 

 +3        SET ^("LIVREG")=$SELECT($DATA(^XTMP("APCLOSP",APCLJOB,APCLBTH,"LIVREG")):(+^("LIVREG")+1),1:1)

 +4        QUIT 

BIRTHS    ;

 +1        SET DOB=$PIECE(^DPT(DFN,0),U,3)

 +2        IF DOB=""

               QUIT 

 +3        IF DOB'<APCLFYB

               IF DOB'>APCLFYE

                   SET ^("BIRTHS")=$SELECT($DATA(^XTMP("APCLOS",APCLJOB,APCLBTH,"BIRTHS")):(+^("BIRTHS")+1),1:1)

 +4        IF DOB'<APCLPYB

               IF DOB'>APCLPYE

                   SET ^("BIRTHS")=$SELECT($DATA(^XTMP("APCLOSP",APCLJOB,APCLBTH,"BIRTHS")):(+^("BIRTHS")+1),1:1)

 +5        QUIT 

DEATHS    ;

 +1        IF '$DATA(DOD)

               QUIT 

 +2        IF DOD'<APCLFYB

               IF DOD'>APCLFYE

                   SET ^("DEATHS")=$SELECT($DATA(^XTMP("APCLOS",APCLJOB,APCLBTH,"DEATHS")):(+^("DEATHS")+1),1:1)

 +3        IF DOD'<APCLPYB

               IF DOD'>APCLPYE

                   SET ^("DEATHS")=$SELECT($DATA(^XTMP("APCLOSP",APCLJOB,APCLBTH,"DEATHS")):(+^("DEATHS")+1),1:1)

 +4        QUIT 

NEWREG    ;

 +1        SET APCLOS="APCLOS"

           SET APCLBDAT=APCLFYB

           SET APCLEDAT=APCLFYE

           DO NEWREG1

 +2        SET APCLOS="APCLOSP"

           SET APCLBDAT=APCLPYB

           SET APCLEDAT=APCLPYE

           DO NEWREG1

 +3        QUIT 

NEWREG1   ;

 +1        IF $PIECE(^AUPNPAT(DFN,0),U,2)<APCLBDAT!($PIECE(^AUPNPAT(DFN,0),U,2)>APCLEDAT)

               QUIT 

 +2        SET ^("NEWREG")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"NEWREG")):(+^("NEWREG")+1),1:1)

 +3       ;

 +4       ;

 +5        QUIT