- ECXSADEN ;BIR/DMA-SAS Report from Dental Extract; 31 Aug 95 / 1:40 PM
- ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
- EN ;entry point from menu option
- W @IOF,!!,"Dental Extract SAS Report",!!
- ;ecxaud=1 for 'sas' audit
- S ECXHEAD="DEN",ECXAUD=1
- ;select extract
- D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
- I ECXERR D AUDIT^ECXKILL Q
- ;select all dental sites/divisions
- S ECXALL=1 D DEN^ECXDVSN(.ECXDIV,ECXALL,.ECXERR)
- I ECXERR D AUDIT^ECXKILL Q
- W !!
- S ECXPGM="PROCESS^ECXSADEN",ECXDESC="Dental Extract SAS Report"
- S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")=""
- W !
- D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
- I ECXSAVE("POP")=1 D Q
- .W !!,?5,"Try agian later... exiting.",!
- .D AUDIT^ECXKILL
- I ECXSAVE("ZTSK")=0 D
- .K ECXSAVE,ECXPGM,ECXDESC
- .D PROCESS
- I IO'=IO(0) D ^%ZISC
- D HOME^%ZIS
- D AUDIT^ECXKILL
- Q
- ;
- PROCESS ;queued entry
- N J,K,X,Y,JJ,SS,LN,PG,DIV,DIVNUM,EC,ECQ,ECFK,ECFL,QFLG,TOT,DIR,DIRUT,DTOUT,DUOUT
- K ^TMP($J,"ECXAUD")
- S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF")
- S (QFLG,PG)=0,$P(LN,"-",80)=""
- ;get run date in external format
- D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y
- ;arrange dental divisions by station #
- S DIV="" F S DIV=$O(ECXDIV(DIV)) Q:DIV="" S DIVNUM=$P(ECXDIV(DIV),U,3),DIV(DIVNUM)=ECXDIV(DIV)
- ;process the extract records
- S J="" F S J=$O(^ECX(727.806,"AC",ECXEXT,J)) Q:'J I $D(^ECX(727.806,J,0)) S EC=^(0),ECFL=$P(EC,U,41) D
- .I $P(EC,U,12) S ^("D09")=$G(^TMP($J,"ECXAUD",ECFL,"D09"))+1
- .F K=10,11,15:1:18,20:1:24,27:1:37 S ECQ=$P(EC,U,K+3) I ECQ S ^("D"_K)=$G(^TMP($J,"ECXAUD",ECFL,"D"_K))+ECQ
- .I $P(EC,U,11)="C" S ^("D08C")=$G(^TMP($J,"ECXAUD",ECFL,"D08C"))+1
- .I $P(EC,U,11)="S" S ^("D08S")=$G(^TMP($J,"ECXAUD",ECFL,"D08S"))+1
- .F K=12,13,14 I $P(EC,U,K+3)=1 S ^("D"_K)=$G(^TMP($J,"ECXAUD",ECFL,"D"_K))+1
- .I $P(EC,U,28)=3 S ^("D25I")=$G(^TMP($J,"ECXAUD",ECFL,"D25I"))+1
- .I $P(EC,U,28)=4 S ^("D25G")=$G(^TMP($J,"ECXAUD",ECFL,"D25G"))+1
- .I $P(EC,U,29)=1 S ^("D26S")=$G(^TMP($J,"ECXAUD",ECFL,"D26S"))+1
- .I $P(EC,U,29)=3 S ^("D26F")=$G(^TMP($J,"ECXAUD",ECFL,"D26F"))+1
- .I $P(EC,U,42)=2 S ^("D39C")=$G(^TMP($J,"ECXAUD",ECFL,"D39C"))+1
- .I $P(EC,U,42)=3 S ^("D39T")=$G(^TMP($J,"ECXAUD",ECFL,"D39T"))+1
- .F K=40:1:42 I $P(EC,U,K+3)=1 S ^("D"_K)=$G(^TMP($J,"ECXAUD",ECFL,"D"_K))+1
- .S EC=$P(EC,U,46),EC=$S(EC=1:"M",EC=2:"Q",EC=3:"R",1:"") I EC]"" S ^("D43"_EC)=$G(^TMP($J,"ECXAUD",ECFL,"D43"_EC))+1
- ;print the report
- U IO
- S ECFL="" F S ECFL=$O(^TMP($J,"ECXAUD",ECFL)) Q:ECFL="" D Q:QFLG
- .D HEADER
- .S TOT(ECFL)=0
- .S ECFK="" F S ECFK=$O(^TMP($J,"ECXAUD",ECFL,ECFK)) Q:ECFK="" S TOT=^(ECFK) D Q:QFLG
- ..D:($Y+3>IOSL) HEADER Q:QFLG W !,?3,ECFL,?43,ECFK,?68,$$RJ^XLFSTR(TOT,5," ")
- ..S TOT(ECFL)=TOT(ECFL)+TOT
- .D:($Y+3>IOSL) HEADER Q:QFLG W !,?40,$E(LN,1,34)
- .D:($Y+3>IOSL) HEADER Q:QFLG W !,"Total for Feeder Location "_ECFL_":",?68,$$RJ^XLFSTR(TOT(ECFL),5," ")
- ;close
- I $E(IOST)'="C" W @IOF
- I $E(IOST)="C",'QFLG D
- .S SS=22-$Y F JJ=1:1:SS W !
- .S DIR(0)="E" W ! D ^DIR K DIR
- D AUDIT^ECXKILL
- Q
- ;
- D SASHEAD^ECXUTLA(ECFL,ECXHEAD,.DIV,.ECXARRAY,.PG)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXSADEN 3152 printed Mar 13, 2025@20:58:25 Page 2
- ECXSADEN ;BIR/DMA-SAS Report from Dental Extract; 31 Aug 95 / 1:40 PM
- +1 ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
- EN ;entry point from menu option
- +1 WRITE @IOF,!!,"Dental Extract SAS Report",!!
- +2 ;ecxaud=1 for 'sas' audit
- +3 SET ECXHEAD="DEN"
- SET ECXAUD=1
- +4 ;select extract
- +5 DO AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
- +6 IF ECXERR
- DO AUDIT^ECXKILL
- QUIT
- +7 ;select all dental sites/divisions
- +8 SET ECXALL=1
- DO DEN^ECXDVSN(.ECXDIV,ECXALL,.ECXERR)
- +9 IF ECXERR
- DO AUDIT^ECXKILL
- QUIT
- +10 WRITE !!
- +11 SET ECXPGM="PROCESS^ECXSADEN"
- SET ECXDESC="Dental Extract SAS Report"
- +12 SET ECXSAVE("ECXHEAD")=""
- SET ECXSAVE("ECXDIV(")=""
- SET ECXSAVE("ECXARRAY(")=""
- +13 WRITE !
- +14 DO DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
- +15 IF ECXSAVE("POP")=1
- Begin DoDot:1
- +16 WRITE !!,?5,"Try agian later... exiting.",!
- +17 DO AUDIT^ECXKILL
- End DoDot:1
- QUIT
- +18 IF ECXSAVE("ZTSK")=0
- Begin DoDot:1
- +19 KILL ECXSAVE,ECXPGM,ECXDESC
- +20 DO PROCESS
- End DoDot:1
- +21 IF IO'=IO(0)
- DO ^%ZISC
- +22 DO HOME^%ZIS
- +23 DO AUDIT^ECXKILL
- +24 QUIT
- +25 ;
- PROCESS ;queued entry
- +1 NEW J,K,X,Y,JJ,SS,LN,PG,DIV,DIVNUM,EC,ECQ,ECFK,ECFL,QFLG,TOT,DIR,DIRUT,DTOUT,DUOUT
- +2 KILL ^TMP($JOB,"ECXAUD")
- +3 SET ECXEXT=ECXARRAY("EXTRACT")
- SET ECXDEF=ECXARRAY("DEF")
- +4 SET (QFLG,PG)=0
- SET $PIECE(LN,"-",80)=""
- +5 ;get run date in external format
- +6 DO NOW^%DTC
- SET Y=$EXTRACT(%,1,12)
- DO DD^%DT
- SET ECXRUN=Y
- +7 ;arrange dental divisions by station #
- +8 SET DIV=""
- FOR
- SET DIV=$ORDER(ECXDIV(DIV))
- if DIV=""
- QUIT
- SET DIVNUM=$PIECE(ECXDIV(DIV),U,3)
- SET DIV(DIVNUM)=ECXDIV(DIV)
- +9 ;process the extract records
- +10 SET J=""
- FOR
- SET J=$ORDER(^ECX(727.806,"AC",ECXEXT,J))
- if 'J
- QUIT
- IF $DATA(^ECX(727.806,J,0))
- SET EC=^(0)
- SET ECFL=$PIECE(EC,U,41)
- Begin DoDot:1
- +11 IF $PIECE(EC,U,12)
- SET ^("D09")=$GET(^TMP($JOB,"ECXAUD",ECFL,"D09"))+1
- +12 FOR K=10,11,15:1:18,20:1:24,27:1:37
- SET ECQ=$PIECE(EC,U,K+3)
- IF ECQ
- SET ^("D"_K)=$GET(^TMP($JOB,"ECXAUD",ECFL,"D"_K))+ECQ
- +13 IF $PIECE(EC,U,11)="C"
- SET ^("D08C")=$GET(^TMP($JOB,"ECXAUD",ECFL,"D08C"))+1
- +14 IF $PIECE(EC,U,11)="S"
- SET ^("D08S")=$GET(^TMP($JOB,"ECXAUD",ECFL,"D08S"))+1
- +15 FOR K=12,13,14
- IF $PIECE(EC,U,K+3)=1
- SET ^("D"_K)=$GET(^TMP($JOB,"ECXAUD",ECFL,"D"_K))+1
- +16 IF $PIECE(EC,U,28)=3
- SET ^("D25I")=$GET(^TMP($JOB,"ECXAUD",ECFL,"D25I"))+1
- +17 IF $PIECE(EC,U,28)=4
- SET ^("D25G")=$GET(^TMP($JOB,"ECXAUD",ECFL,"D25G"))+1
- +18 IF $PIECE(EC,U,29)=1
- SET ^("D26S")=$GET(^TMP($JOB,"ECXAUD",ECFL,"D26S"))+1
- +19 IF $PIECE(EC,U,29)=3
- SET ^("D26F")=$GET(^TMP($JOB,"ECXAUD",ECFL,"D26F"))+1
- +20 IF $PIECE(EC,U,42)=2
- SET ^("D39C")=$GET(^TMP($JOB,"ECXAUD",ECFL,"D39C"))+1
- +21 IF $PIECE(EC,U,42)=3
- SET ^("D39T")=$GET(^TMP($JOB,"ECXAUD",ECFL,"D39T"))+1
- +22 FOR K=40:1:42
- IF $PIECE(EC,U,K+3)=1
- SET ^("D"_K)=$GET(^TMP($JOB,"ECXAUD",ECFL,"D"_K))+1
- +23 SET EC=$PIECE(EC,U,46)
- SET EC=$SELECT(EC=1:"M",EC=2:"Q",EC=3:"R",1:"")
- IF EC]""
- SET ^("D43"_EC)=$GET(^TMP($JOB,"ECXAUD",ECFL,"D43"_EC))+1
- End DoDot:1
- +24 ;print the report
- +25 USE IO
- +26 SET ECFL=""
- FOR
- SET ECFL=$ORDER(^TMP($JOB,"ECXAUD",ECFL))
- if ECFL=""
- QUIT
- Begin DoDot:1
- +27 DO HEADER
- +28 SET TOT(ECFL)=0
- +29 SET ECFK=""
- FOR
- SET ECFK=$ORDER(^TMP($JOB,"ECXAUD",ECFL,ECFK))
- if ECFK=""
- QUIT
- SET TOT=^(ECFK)
- Begin DoDot:2
- +30 if ($Y+3>IOSL)
- DO HEADER
- if QFLG
- QUIT
- WRITE !,?3,ECFL,?43,ECFK,?68,$$RJ^XLFSTR(TOT,5," ")
- +31 SET TOT(ECFL)=TOT(ECFL)+TOT
- End DoDot:2
- if QFLG
- QUIT
- +32 if ($Y+3>IOSL)
- DO HEADER
- if QFLG
- QUIT
- WRITE !,?40,$EXTRACT(LN,1,34)
- +33 if ($Y+3>IOSL)
- DO HEADER
- if QFLG
- QUIT
- WRITE !,"Total for Feeder Location "_ECFL_":",?68,$$RJ^XLFSTR(TOT(ECFL),5," ")
- End DoDot:1
- if QFLG
- QUIT
- +34 ;close
- +35 IF $EXTRACT(IOST)'="C"
- WRITE @IOF
- +36 IF $EXTRACT(IOST)="C"
- IF 'QFLG
- Begin DoDot:1
- +37 SET SS=22-$Y
- FOR JJ=1:1:SS
- WRITE !
- +38 SET DIR(0)="E"
- WRITE !
- DO ^DIR
- KILL DIR
- End DoDot:1
- +39 DO AUDIT^ECXKILL
- +40 QUIT
- +41 ;
- +1 DO SASHEAD^ECXUTLA(ECFL,ECXHEAD,.DIV,.ECXARRAY,.PG)
- +2 QUIT
