- APCLDM5 ; IHS/CMI/LAB - DM AUDIT ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;
- ;
- EN ;ENTRY POINT FROM APCLDM1
- D HEADER
- D IDENT
- Q
- 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
- +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 ;
