APCLDM5.m

APCLDM5 ; IHS/CMI/LAB - DM AUDIT ;

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

 ;

 ;

EN ;ENTRY POINT FROM APCLDM1

 D HEADER

 D IDENT

 Q

HEADER ; Set node with report header info

 S APCLAREA=$P(^AUTTAREA($P(^AUTTLOC(DUZ(2),0),U,4),0),U) ;_" - "_$P(^(0),U)

 S APCLSU=$P(^AUTTSU($P(^AUTTLOC(DUZ(2),0),U,5),0),U)

 S APCLFAC=$P(^DIC(4,DUZ(2),0),U)

 I '$D(APCLFISC) D

 . S APCLDTE=APCLBDT_" - "_APCLEDT

 S (^TMP("APCL",$J,1000),^TMP("APCLCUML",$J,1000))=APCLTDTE

 S (^TMP("APCL",$J,1001),^TMP("APCLCUML",$J,1001))=$S($D(APCLDTE):APCLDTE,1:APCLFISC)

 S (^TMP("APCL",$J,1002),^TMP("APCLCUML",$J,1002))=APCLAREA

 S (^TMP("APCL",$J,1003),^TMP("APCLCUML",$J,1003))=APCLSU

 S (^TMP("APCL",$J,1004),^TMP("APCLCUML",$J,1004))=APCLFAC

 S (^TMP("APCL",$J,1005),^TMP("APCLCUML",$J,1005))=$P(^VA(200,DUZ,0),U)

 S ^TMP("APCL",$J,42)=$$FMTE^XLFDT(APCLED)

 S APCLUED=$S(APCLED>DT:DT,1:APCLED)

 Q

 ;

IDENT ; Pt identifying factors

 I APCLCUML S ^(1)=$G(^TMP("APCLCUML",$J,1))+1

 S Y=$P(^DPT(APCLPD,0),U,3) D DD^%DT

 S ^TMP("APCL",$J,500)=$P($G(^AUPNPAT(APCLPD,41,DUZ(2),0)),U,2)

 S ^TMP("APCL",$J,501)=Y

 S (^TMP("APCL",$J,502),APCLSEX)=$P(^DPT(APCLPD,0),U,2)

 S ^TMP("APCL",$J,504)=$P(^DPT(APCLPD,0),U)

 I APCLCUML D  S APCLSUB=2 D CUML

 . I APCLSEX="F" S APCLGOT1=1

 . E  S APCLGOT1=0

 S (APCLAGE,^TMP("APCL",$J,503))=(APCLED-$P(^DPT(APCLPD,0),U,3))\10000 I APCLCUML D

 . I APCLAGE<15 S APCLGOT1=1,APCLSUB=50 D CUML F APCLSUB=51,52,53 S APCLGOT1=0 D CUML

 . I APCLAGE>14&(APCLAGE<45) S APCLGOT1=1,APCLSUB=51 D CUML F APCLSUB=50,52,53 S APCLGOT1=0 D CUML

 . I APCLAGE>44&(APCLAGE<65) S APCLGOT1=1,APCLSUB=52 D CUML F APCLSUB=50,51,53 S APCLGOT1=0 D CUML

 . I APCLAGE>64 S APCLGOT1=1,APCLSUB=53 D CUML F APCLSUB=50,51,52 S APCLGOT1=0 D CUML

 K APCLAGE

 Q

 ;

CUML ; - ENTRY POINT - Set cumulative nodes

 I '$D(^TMP("APCLCUML",$J,APCLSUB)) S ^TMP("APCLCUML",$J,APCLSUB)=APCLGOT1_"/"_1

 E  S ^(APCLSUB)=$S(APCLGOT1:$P(^TMP("APCLCUML",$J,APCLSUB),"/")+1,1:$P(^TMP("APCLCUML",$J,APCLSUB),"/"))_"/"_($P(^(APCLSUB),"/",2)+1)

 Q

 ;

CLEAN ;EP

 K ^TMP("APCLDM FETCH",$J),^TMP("APCLDM DXVS",$J),^TMP("APCLDM VST",$J)

 K APCLDX,APCLVST,APCLDXVS,APCLHT,APCLMEAS,APCLL,APCLTOT,APCLMDFN,APCLVDFN,APCLYES,APCLPOD,APCLCL1,APCLCL2,APCLX,APCLY,APCLEYE1,APCLEYE2,APCLPCL1,APCLPCL2,APCLPCL3,APCLPRD,APCLPRV,APCLTD,APCLFDX

 K APCLDAYS,APCLDP,APCLHTK1

 K APCLAREA,APCLSU,APCLFAC,APCLDTE,APCLI,APCLSEX,APCLSUB,APCLGOT1,APCLER,APCLERTX,APCLHTNE,APCLDOO,APCLLL,APCLPCL

 K APCLRTYP,APCLVMED,APCLW

 Q

 ;

APCLDM5   ; IHS/CMI/LAB - DM AUDIT ;

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

 +2       ;

 +3       ;

EN        ;ENTRY POINT FROM APCLDM1

 +1        DO HEADER

 +2        DO IDENT

 +3        QUIT 

HEADER    ; Set node with report header info

 +1       ;_" - "_$P(^(0),U)

           SET APCLAREA=$PIECE(^AUTTAREA($PIECE(^AUTTLOC(DUZ(2),0),U,4),0),U)

 +2        SET APCLSU=$PIECE(^AUTTSU($PIECE(^AUTTLOC(DUZ(2),0),U,5),0),U)

 +3        SET APCLFAC=$PIECE(^DIC(4,DUZ(2),0),U)

 +4        IF '$DATA(APCLFISC)

               Begin DoDot:1

 +5                SET APCLDTE=APCLBDT_" - "_APCLEDT

               End DoDot:1

 +6        SET (^TMP("APCL",$JOB,1000),^TMP("APCLCUML",$JOB,1000))=APCLTDTE

 +7        SET (^TMP("APCL",$JOB,1001),^TMP("APCLCUML",$JOB,1001))=$SELECT($DATA(APCLDTE):APCLDTE,1:APCLFISC)

 +8        SET (^TMP("APCL",$JOB,1002),^TMP("APCLCUML",$JOB,1002))=APCLAREA

 +9        SET (^TMP("APCL",$JOB,1003),^TMP("APCLCUML",$JOB,1003))=APCLSU

 +10       SET (^TMP("APCL",$JOB,1004),^TMP("APCLCUML",$JOB,1004))=APCLFAC

 +11       SET (^TMP("APCL",$JOB,1005),^TMP("APCLCUML",$JOB,1005))=$PIECE(^VA(200,DUZ,0),U)

 +12       SET ^TMP("APCL",$JOB,42)=$$FMTE^XLFDT(APCLED)

 +13       SET APCLUED=$SELECT(APCLED>DT:DT,1:APCLED)

 +14       QUIT 

 +15      ;

IDENT     ; Pt identifying factors

 +1        IF APCLCUML

               SET ^(1)=$GET(^TMP("APCLCUML",$JOB,1))+1

 +2        SET Y=$PIECE(^DPT(APCLPD,0),U,3)

           DO DD^%DT

 +3        SET ^TMP("APCL",$JOB,500)=$PIECE($GET(^AUPNPAT(APCLPD,41,DUZ(2),0)),U,2)

 +4        SET ^TMP("APCL",$JOB,501)=Y

 +5        SET (^TMP("APCL",$JOB,502),APCLSEX)=$PIECE(^DPT(APCLPD,0),U,2)

 +6        SET ^TMP("APCL",$JOB,504)=$PIECE(^DPT(APCLPD,0),U)

 +7        IF APCLCUML

               Begin DoDot:1

 +8                IF APCLSEX="F"

                       SET APCLGOT1=1

 +9               IF '$TEST

                       SET APCLGOT1=0

               End DoDot:1

               SET APCLSUB=2

               DO CUML

 +10       SET (APCLAGE,^TMP("APCL",$JOB,503))=(APCLED-$PIECE(^DPT(APCLPD,0),U,3))\10000

           IF APCLCUML

               Begin DoDot:1

 +11               IF APCLAGE<15

                       SET APCLGOT1=1

                       SET APCLSUB=50

                       DO CUML

                       FOR APCLSUB=51,52,53

                           SET APCLGOT1=0

                           DO CUML

 +12               IF APCLAGE>14&(APCLAGE<45)

                       SET APCLGOT1=1

                       SET APCLSUB=51

                       DO CUML

                       FOR APCLSUB=50,52,53

                           SET APCLGOT1=0

                           DO CUML

 +13               IF APCLAGE>44&(APCLAGE<65)

                       SET APCLGOT1=1

                       SET APCLSUB=52

                       DO CUML

                       FOR APCLSUB=50,51,53

                           SET APCLGOT1=0

                           DO CUML

 +14               IF APCLAGE>64

                       SET APCLGOT1=1

                       SET APCLSUB=53

                       DO CUML

                       FOR APCLSUB=50,51,52

                           SET APCLGOT1=0

                           DO CUML

               End DoDot:1

 +15       KILL APCLAGE

 +16       QUIT 

 +17      ;

CUML      ; - ENTRY POINT - Set cumulative nodes

 +1        IF '$DATA(^TMP("APCLCUML",$JOB,APCLSUB))

               SET ^TMP("APCLCUML",$JOB,APCLSUB)=APCLGOT1_"/"_1

 +2       IF '$TEST

               SET ^(APCLSUB)=$SELECT(APCLGOT1:$PIECE(^TMP("APCLCUML",$JOB,APCLSUB),"/")+1,1:$PIECE(^TMP("APCLCUML",$JOB,APCLSUB),"/"))_"/"_($PIECE(^(APCLSUB),"/",2)+1)

 +3        QUIT 

 +4       ;

CLEAN     ;EP

 +1        KILL ^TMP("APCLDM FETCH",$JOB),^TMP("APCLDM DXVS",$JOB),^TMP("APCLDM VST",$JOB)

 +2        KILL APCLDX,APCLVST,APCLDXVS,APCLHT,APCLMEAS,APCLL,APCLTOT,APCLMDFN,APCLVDFN,APCLYES,APCLPOD,APCLCL1,APCLCL2,APCLX,APCLY,APCLEYE1,APCLEYE2,APCLPCL1,APCLPCL2,APCLPCL3,APCLPRD,APCLPRV,APCLTD,APCLFDX

 +3        KILL APCLDAYS,APCLDP,APCLHTK1

 +4        KILL APCLAREA,APCLSU,APCLFAC,APCLDTE,APCLI,APCLSEX,APCLSUB,APCLGOT1,APCLER,APCLERTX,APCLHTNE,APCLDOO,APCLLL,APCLPCL

 +5        KILL APCLRTYP,APCLVMED,APCLW

 +6        QUIT 

 +7       ;