- ECXUTLA ;ALB/JAP - Utilities for Audit Reports ;3/9/16 16:18
- ;;3.0;DSS EXTRACTS;**8,14,112,154,161**;Dec 22, 1997;Build 6
- ;
- AUDIT(ECXHEAD,ECXERR,ECXARRAY,ECXAUD) ;set audit report parameters
- ; input
- ; ECXHEAD = extract HEADER CODE (required)
- ; (from file #727.1, field #7)
- ; ECXERR = passed-by-reference variable (required)
- ; ECXARRAY = passed-by-reference array (required)
- ; ECXAUD = 0/1 (optional)
- ; 0 --> extract audit (default)
- ; 1 --> SAS audit
- ; output
- ; ECXARRAY = array of audit parameters
- ; ECXARRAY("DEF") = ien of extract type in file #727.1
- ; ECXARRAY("TYPE") = print name for extract; field #7 in file #727.1
- ; ECXARRAY("EXTRACT") = ien of extract in file #727
- ; ECXARRAY("START") = start date for extract audit
- ; ECXARRAY("END") = end date for extract audit
- ; ECXARRAY("ERUN") = date on which extract was generated
- ; ECXARRAY("DIV") = ien of station if file #4
- ; error CODE
- ; ECXERR = 1, if input problem occurs
- ; 0, otherwise
- ;
- N X,Y,N,DA,DIC,DIQ,DIR,DTOUT,DUOUT,DIRUT,ECXDA,ECXTYPE,ECXSTART,ECXEND,ECXARR
- S ECXERR=0
- S N=$O(^ECX(727.1,"C",ECXHEAD,"")) S:N="" ECXERR=1
- Q:ECXERR
- S DIC="^ECX(727.1,",DIC(0)="NZ",X=N
- D ^DIC I Y=-1 S ECXERR=1 Q
- S ECXTYPE=$P(Y(0),U,7)_U_+Y K X,Y,DIC
- I $G(ECXAUD)=1,ECXHEAD'="DEN",ECXHEAD'="PRE",ECXHEAD'="RAD",ECXHEAD'="SUR" S ECXERR=1
- Q:ECXERR
- S DIC="^ECX(727,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)=$P(ECXTYPE,U),'$D(^(""PURG""))"
- D ^DIC
- I Y=-1!($G(DUOUT))!($G(DTOUT)) D:'$G(ECXAUD) RUN S ECXERR=1 Q ;154
- S DIC="^ECX(727,",(DA,ECXDA)=+Y,DR=".01;1;2;3;4;5;15;300",DIQ="ECXARR",DIQ(0)="IE"
- D EN^DIQ1
- W !!,?5,"Extract: ",ECXARR(727,ECXDA,2,"E")," #",ECXDA
- W !!,?5,"Start date: ",ECXARR(727,ECXDA,3,"E")
- W !,?5,"End date: ",ECXARR(727,ECXDA,4,"E")
- W !,?5,"# of Records: ",ECXARR(727,ECXDA,5,"E")
- I ECXHEAD="PRO" W !,?5,"Station: ",ECXARR(727,ECXDA,15,"E")
- ;if transmit date exists, then ask user if audit still needed
- I $L(ECXARR(727,ECXDA,300,"E"))>0 D
- .W !!,?5,"The extract which you have chosen to audit"
- .W !,?5,"was transmitted to Austin/DSS on ",ECXARR(727,ECXDA,300,"E"),".",!
- .S DIR(0)="Y",DIR("A")="Do you want to continue with this audit report",DIR("B")="NO" D ^DIR
- .S:$G(DIRUT) ECXERR=1 S:Y=0 ECXERR=1
- Q:ECXERR
- ;setup the return array
- S ECXARRAY("EXTRACT")=ECXARR(727,ECXDA,.01,"E"),ECXARRAY("DIV")=ECXARR(727,ECXDA,15,"I"),ECXARRAY("TYPE")=$P(ECXTYPE,U),ECXARRAY("DEF")=$P(ECXTYPE,U,2)
- S ECXARRAY("START")=ECXARR(727,ECXDA,3,"E"),ECXARRAY("END")=ECXARR(727,ECXDA,4,"E"),ECXARRAY("ERUN")=ECXARR(727,ECXDA,1,"E")
- ;determine date range only for extract audit reports
- I $G(ECXAUD)=0 D
- .S ECXSTART=ECXARRAY("START"),ECXEND=ECXARRAY("END") D RANGE^ECXUTLA(.ECXSTART,.ECXEND,.ECXERR)
- .I ECXERR K ECXARRAY
- .Q:ECXERR
- .S ECXARRAY("START")=ECXSTART,ECXARRAY("END")=ECXEND
- Q
- ;
- RANGE(ECXSTART,ECXEND,ECXERR) ;determine date range for extract audit report
- ; input
- ; ECXSTART = start date of extract in file #727 (required)
- ; passed by reference
- ; ECXEND = end date of extract in file #727 (required)
- ; passed by reference
- ; ECXERR = passed by reference (required)
- ; output
- ; ECXSTART = user selected start date
- ; ECXEND = user selected end date
- ; error CODE
- ; ECXERR = 1, if input problem occurs
- ; 0, otherwise
- ;
- ;
- ;convert dates to internal format
- N DATEA,DATEB,X,Y,%DT,DTOUT,OUT
- S (ECXERR,OUT)=0
- S X=ECXSTART D ^%DT S DATEA=Y
- S X=ECXEND D ^%DT S DATEB=Y
- ;allow user to select start date
- ;can't be less than ecxstart or greater than ecxend
- W !!,?5,"You can narrow the date range, if you wish.",!
- W !,?5,"The Start Date can't be earlier than ",ECXSTART,","
- W !,?5,"or later than ",ECXEND,".",!
- F Q:OUT!ECXERR D
- .S %DT="AEX",%DT("A")="Select Start Date: ",%DT("B")=ECXSTART,%DT(0)=DATEA
- .D ^%DT S:Y=-1 ECXERR=1 S:$G(DTOUT) ECXERR=1
- .Q:ECXERR
- .I Y>DATEB D Q
- ..W !,?5,"But that's later than ",ECXEND,"...try again.",!
- .S DATEA=Y,OUT=1
- I ECXERR K ECXSTART,ECXEND
- Q:ECXERR
- S Y=DATEA D DD^%DT S ECXSTART=Y
- ;allow user to select end date
- ;can't be less than ecxstart or greater than ecxend
- W !!,?5,"The End Date can't be earlier than ",ECXSTART
- W !,?5,"(the Start Date you selected), or later than ",ECXEND,".",!
- S OUT=0
- F Q:OUT!ECXERR D
- .S %DT="AEX",%DT("A")="Select End Date: ",%DT("B")=ECXEND,%DT(0)=-DATEB
- .D ^%DT S:Y=-1 ECXERR=1 S:$G(DTOUT) ECXERR=1
- .Q:ECXERR
- .I Y<DATEA D Q
- ..W !,?5,"But that's earlier than ",ECXSTART,"...try again.",!
- .S DATEB=Y,OUT=1
- I ECXERR K ECXSTART,ECXEND
- Q:ECXERR
- S Y=DATEB D DD^%DT S ECXEND=Y
- Q
- ;
- DEVICE(ZTRTN,ZTDESC,ZTSAVE) ;get print device and optionally task to background
- ; input
- ; ZTRTN = line^routine; task entry point (required)
- ; variable for %ZTLOAD
- ; ZTDESC = task description (required)
- ; variable for %ZTLOAD
- ; ZTSAVE = array; passed by reference (required)
- ; variables for %ZTLOAD
- ; output
- ; ZTSAVE = returns ZTSAVE("POP"),ZTSAVE("ZTSK")
- ;
- N POP,ZTSK
- S ZTSAVE("POP")=0,ZTSAVE("ZTSK")=0
- ;return ztsave("pop")=1 and quit if required input not available
- I '$L(ZTRTN)!('$L(ZTDESC))!('$D(ZTSAVE)) S ZTSAVE("POP")=1 Q
- ;get print device
- K IO("Q") S %ZIS="QM" D ^%ZIS
- S ZTSAVE("POP")=POP
- I POP D
- .W !,"No device selected...exiting.",!
- Q:POP
- I $D(IO("Q")) D
- .S ZTSAVE("ZTREQ")="@"
- .D ^%ZTLOAD
- .I $G(ZTSK)>0 D
- ..W !,"Request queued as Task #",ZTSK,".",!
- ..S ZTSAVE("ZTSK")=ZTSK
- ..S ZTSAVE("POP")=0
- .I '$G(ZTSK) D
- ..W !,"Request to queue cancelled...exiting.",!
- ..S ZTSAVE("ZTSK")=0
- ..S ZTSAVE("POP")=1
- Q
- ;
- WARDS(ECXALL,ECXDIV) ;get wards for selected divisions
- ; input
- ; ECXALL = 1/0 (optional)
- ; 1==> user selected all divisions OR
- ; facility is non-divisional
- ; 0==> user selected some divisions
- ; if ECXALL not defined, then assume 1
- ; ECXDIV = array of divisions selected (optional)
- ; passed by reference array containing
- ; selected divisions;
- ; if ECXALL=1, then ECXDIV array isn't
- ; required; information for all wards will be obtained
- ; if ECXALL=0, then only wards for divisions in ECXDIV
- ; output
- ; ^TMP($J,"ECXWARD", contains ward name, division, g&l order
- ; ^TMP($J,"ECXORDER", contains ward grouping info
- ;
- N IEN,WARD,ORDX,NAME,NM,ORDER,DIV,HIEN,GROUP,DATA,DEPT,NAMEDEPT
- K ^TMP($J,"ECXWARD"),^TMP($J,"ECXORDER")
- ;if ecxall not here, then set ecxall=1
- S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
- S ORDX=0,NM=""
- F S NM=$O(^DIC(42,"B",NM)) Q:NM="" S IEN=0 F S IEN=$O(^DIC(42,"B",NM,IEN)) Q:IEN="" D
- .S DIV=+$P(^DIC(42,IEN,0),U,11) Q:DIV=0
- .I ECXALL=0,'$D(ECXDIV(DIV)) Q
- .S (NAME,ORDER,DEPT)="",NAME=$P(^DIC(42,IEN,0),U,1),ORDER=+$P($G(^DIC(42,IEN,"ORDER")),U,1),DEPT=$P($G(^ECX(727.4,IEN,0)),U,2)
- .;'unordered' ward is probably inactive, but get basic data anyway
- .I ORDER=0 S ORDX=ORDX+1,ORDER="99999"_ORDX,ORDER=+ORDER
- .;get this ward's ien in file #44; file #727.802 & #727.808 use pointers to file #44
- .S HIEN=+$P($G(^DIC(42,IEN,44)),U,1) Q:HIEN=0
- .;if this is last ward in group, then get the group name
- .K GROUP I $D(^DIC(42,IEN,1,1,0)) S GROUP=$P(^DIC(42,IEN,1,1,0),U,1) I GROUP="" K GROUP
- .S ^TMP($J,"ECXWARD",HIEN)=ORDER_U_NAME_U_DIV_U_IEN_U_DEPT
- .I $D(GROUP) S ^TMP($J,"ECXWARD",HIEN,1)=GROUP
- ;after all wards in file #42 are processed, arrange by g&l order
- S HIEN=0
- F S HIEN=$O(^TMP($J,"ECXWARD",HIEN)) Q:HIEN="" S DATA=^TMP($J,"ECXWARD",HIEN) D
- .S ORDER=$P(DATA,U,1),NAME=$P(DATA,U,2),DIV=$P(DATA,U,3),DEPT=$P(DATA,U,5)
- .S NAMEDEPT=NAME S:DEPT]"" NAMEDEPT=NAME_" <"_DEPT_">"
- .S ^TMP($J,"ECXORDER",DIV,ORDER)=HIEN_U_NAMEDEPT_U
- .I $D(^TMP($J,"ECXWARD",HIEN,1)) S GROUP=^(1),^TMP($J,"ECXORDER",DIV,ORDER,1)=1_U_GROUP_U
- Q
- ;
- SASHEAD(ECXFL,ECXHEAD,ECXDIV,ECXARRAY,ECXPG,ECXTAB) ;header and page control
- ;
- ; ECXFL = feeder location (division) (required)
- ; ECXHEAD = extract header from file #727.1 (required)
- ; ECXDIV = array of divisions selected (required)
- ; ECXPG = page number (required)
- ; ECXTAB = tab location;
- ; allows for proper spacing in sub-header line (optional)
- ;
- N JJ,SS,LN
- S $P(LN,"-",80)=""
- I $G(ECXTAB)="" S ECXTAB=40
- I $E(IOST)="C" D
- .S SS=22-$Y F JJ=1:1:SS W !
- .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
- Q:QFLG
- W:$Y!($E(IOST)="C") @IOF S ECXPG=ECXPG+1
- W !,"SAS Audit Report for "_ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract"
- W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT")
- W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
- W !,"Report Run Date/Time: "_ECXRUN
- I $D(ECXDIV(ECXFL)) W !,"Division/Site: "_$P(ECXDIV(ECXFL),U,2)_" ("_ECXFL_")",?68,"Page: "_ECXPG
- I '$D(ECXDIV(ECXFL)) W !,"Division/Site: "_"Unknown",?68,"Page: "_ECXPG
- I ECXHEAD="SUR" W !!,"Feeder",?12,"Feeder Location",!,"Location",?12,"Name",?ECXTAB,"Feeder Key",?68,"Quantity" ;161 Special header for SUR only
- I ECXHEAD'="SUR" W !!,"Feeder Location",?ECXTAB,"Feeder Key",?68,"Quantity" ;161 Non-SUR report header
- W !,LN,!
- Q
- ;
- RUN ;154 Section allows extract to be run from within audit report
- N DIR,X,Y,DTOUT,DUOUT,ECPACK,ECGRP,ECFILE,ECRTN,ECPIECE,ECVER,ECHEAD,ECXAUDIT
- W !
- S DIR("A",1)="You didn't select an existing extract log record number. Remember"
- S DIR("A",2)="the extract must be run first, before you can run this audit."
- S DIR("A",3)="If there is no log record number, run the extract from the Package Extracts"
- S DIR("A",4)="menu or if unavailable there, from here (you will be prompted to"
- S DIR("A",5)="queue the extract below)."
- S DIR("A",6)=""
- S DIR("A",7)="Remember that if you queue the extract to run from here"
- S DIR("A",8)="(the extract audit report menu), you may have to wait overnight for the"
- S DIR("A",9)="extract to finish. It must finish before you can pick its log record number"
- S DIR("A",10)="to run the extract audit."
- S DIR("A",11)=""
- S DIR("A")="Would you like to queue the "_ECXHEAD_" extract"
- S DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR
- Q:Y'=1
- S ECHEAD=ECXHEAD,ECXAUDIT=1
- D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
- I ECFILE="" Q
- D ^ECXTRAC,^ECXKILL
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXUTLA 10583 printed Jan 18, 2025@02:55:42 Page 2
- ECXUTLA ;ALB/JAP - Utilities for Audit Reports ;3/9/16 16:18
- +1 ;;3.0;DSS EXTRACTS;**8,14,112,154,161**;Dec 22, 1997;Build 6
- +2 ;
- AUDIT(ECXHEAD,ECXERR,ECXARRAY,ECXAUD) ;set audit report parameters
- +1 ; input
- +2 ; ECXHEAD = extract HEADER CODE (required)
- +3 ; (from file #727.1, field #7)
- +4 ; ECXERR = passed-by-reference variable (required)
- +5 ; ECXARRAY = passed-by-reference array (required)
- +6 ; ECXAUD = 0/1 (optional)
- +7 ; 0 --> extract audit (default)
- +8 ; 1 --> SAS audit
- +9 ; output
- +10 ; ECXARRAY = array of audit parameters
- +11 ; ECXARRAY("DEF") = ien of extract type in file #727.1
- +12 ; ECXARRAY("TYPE") = print name for extract; field #7 in file #727.1
- +13 ; ECXARRAY("EXTRACT") = ien of extract in file #727
- +14 ; ECXARRAY("START") = start date for extract audit
- +15 ; ECXARRAY("END") = end date for extract audit
- +16 ; ECXARRAY("ERUN") = date on which extract was generated
- +17 ; ECXARRAY("DIV") = ien of station if file #4
- +18 ; error CODE
- +19 ; ECXERR = 1, if input problem occurs
- +20 ; 0, otherwise
- +21 ;
- +22 NEW X,Y,N,DA,DIC,DIQ,DIR,DTOUT,DUOUT,DIRUT,ECXDA,ECXTYPE,ECXSTART,ECXEND,ECXARR
- +23 SET ECXERR=0
- +24 SET N=$ORDER(^ECX(727.1,"C",ECXHEAD,""))
- if N=""
- SET ECXERR=1
- +25 if ECXERR
- QUIT
- +26 SET DIC="^ECX(727.1,"
- SET DIC(0)="NZ"
- SET X=N
- +27 DO ^DIC
- IF Y=-1
- SET ECXERR=1
- QUIT
- +28 SET ECXTYPE=$PIECE(Y(0),U,7)_U_+Y
- KILL X,Y,DIC
- +29 IF $GET(ECXAUD)=1
- IF ECXHEAD'="DEN"
- IF ECXHEAD'="PRE"
- IF ECXHEAD'="RAD"
- IF ECXHEAD'="SUR"
- SET ECXERR=1
- +30 if ECXERR
- QUIT
- +31 SET DIC="^ECX(727,"
- SET DIC(0)="AEMQ"
- SET DIC("S")="I $P(^(0),U,3)=$P(ECXTYPE,U),'$D(^(""PURG""))"
- +32 DO ^DIC
- +33 ;154
- IF Y=-1!($GET(DUOUT))!($GET(DTOUT))
- if '$GET(ECXAUD)
- DO RUN
- SET ECXERR=1
- QUIT
- +34 SET DIC="^ECX(727,"
- SET (DA,ECXDA)=+Y
- SET DR=".01;1;2;3;4;5;15;300"
- SET DIQ="ECXARR"
- SET DIQ(0)="IE"
- +35 DO EN^DIQ1
- +36 WRITE !!,?5,"Extract: ",ECXARR(727,ECXDA,2,"E")," #",ECXDA
- +37 WRITE !!,?5,"Start date: ",ECXARR(727,ECXDA,3,"E")
- +38 WRITE !,?5,"End date: ",ECXARR(727,ECXDA,4,"E")
- +39 WRITE !,?5,"# of Records: ",ECXARR(727,ECXDA,5,"E")
- +40 IF ECXHEAD="PRO"
- WRITE !,?5,"Station: ",ECXARR(727,ECXDA,15,"E")
- +41 ;if transmit date exists, then ask user if audit still needed
- +42 IF $LENGTH(ECXARR(727,ECXDA,300,"E"))>0
- Begin DoDot:1
- +43 WRITE !!,?5,"The extract which you have chosen to audit"
- +44 WRITE !,?5,"was transmitted to Austin/DSS on ",ECXARR(727,ECXDA,300,"E"),".",!
- +45 SET DIR(0)="Y"
- SET DIR("A")="Do you want to continue with this audit report"
- SET DIR("B")="NO"
- DO ^DIR
- +46 if $GET(DIRUT)
- SET ECXERR=1
- if Y=0
- SET ECXERR=1
- End DoDot:1
- +47 if ECXERR
- QUIT
- +48 ;setup the return array
- +49 SET ECXARRAY("EXTRACT")=ECXARR(727,ECXDA,.01,"E")
- SET ECXARRAY("DIV")=ECXARR(727,ECXDA,15,"I")
- SET ECXARRAY("TYPE")=$PIECE(ECXTYPE,U)
- SET ECXARRAY("DEF")=$PIECE(ECXTYPE,U,2)
- +50 SET ECXARRAY("START")=ECXARR(727,ECXDA,3,"E")
- SET ECXARRAY("END")=ECXARR(727,ECXDA,4,"E")
- SET ECXARRAY("ERUN")=ECXARR(727,ECXDA,1,"E")
- +51 ;determine date range only for extract audit reports
- +52 IF $GET(ECXAUD)=0
- Begin DoDot:1
- +53 SET ECXSTART=ECXARRAY("START")
- SET ECXEND=ECXARRAY("END")
- DO RANGE^ECXUTLA(.ECXSTART,.ECXEND,.ECXERR)
- +54 IF ECXERR
- KILL ECXARRAY
- +55 if ECXERR
- QUIT
- +56 SET ECXARRAY("START")=ECXSTART
- SET ECXARRAY("END")=ECXEND
- End DoDot:1
- +57 QUIT
- +58 ;
- RANGE(ECXSTART,ECXEND,ECXERR) ;determine date range for extract audit report
- +1 ; input
- +2 ; ECXSTART = start date of extract in file #727 (required)
- +3 ; passed by reference
- +4 ; ECXEND = end date of extract in file #727 (required)
- +5 ; passed by reference
- +6 ; ECXERR = passed by reference (required)
- +7 ; output
- +8 ; ECXSTART = user selected start date
- +9 ; ECXEND = user selected end date
- +10 ; error CODE
- +11 ; ECXERR = 1, if input problem occurs
- +12 ; 0, otherwise
- +13 ;
- +14 ;
- +15 ;convert dates to internal format
- +16 NEW DATEA,DATEB,X,Y,%DT,DTOUT,OUT
- +17 SET (ECXERR,OUT)=0
- +18 SET X=ECXSTART
- DO ^%DT
- SET DATEA=Y
- +19 SET X=ECXEND
- DO ^%DT
- SET DATEB=Y
- +20 ;allow user to select start date
- +21 ;can't be less than ecxstart or greater than ecxend
- +22 WRITE !!,?5,"You can narrow the date range, if you wish.",!
- +23 WRITE !,?5,"The Start Date can't be earlier than ",ECXSTART,","
- +24 WRITE !,?5,"or later than ",ECXEND,".",!
- +25 FOR
- if OUT!ECXERR
- QUIT
- Begin DoDot:1
- +26 SET %DT="AEX"
- SET %DT("A")="Select Start Date: "
- SET %DT("B")=ECXSTART
- SET %DT(0)=DATEA
- +27 DO ^%DT
- if Y=-1
- SET ECXERR=1
- if $GET(DTOUT)
- SET ECXERR=1
- +28 if ECXERR
- QUIT
- +29 IF Y>DATEB
- Begin DoDot:2
- +30 WRITE !,?5,"But that's later than ",ECXEND,"...try again.",!
- End DoDot:2
- QUIT
- +31 SET DATEA=Y
- SET OUT=1
- End DoDot:1
- +32 IF ECXERR
- KILL ECXSTART,ECXEND
- +33 if ECXERR
- QUIT
- +34 SET Y=DATEA
- DO DD^%DT
- SET ECXSTART=Y
- +35 ;allow user to select end date
- +36 ;can't be less than ecxstart or greater than ecxend
- +37 WRITE !!,?5,"The End Date can't be earlier than ",ECXSTART
- +38 WRITE !,?5,"(the Start Date you selected), or later than ",ECXEND,".",!
- +39 SET OUT=0
- +40 FOR
- if OUT!ECXERR
- QUIT
- Begin DoDot:1
- +41 SET %DT="AEX"
- SET %DT("A")="Select End Date: "
- SET %DT("B")=ECXEND
- SET %DT(0)=-DATEB
- +42 DO ^%DT
- if Y=-1
- SET ECXERR=1
- if $GET(DTOUT)
- SET ECXERR=1
- +43 if ECXERR
- QUIT
- +44 IF Y<DATEA
- Begin DoDot:2
- +45 WRITE !,?5,"But that's earlier than ",ECXSTART,"...try again.",!
- End DoDot:2
- QUIT
- +46 SET DATEB=Y
- SET OUT=1
- End DoDot:1
- +47 IF ECXERR
- KILL ECXSTART,ECXEND
- +48 if ECXERR
- QUIT
- +49 SET Y=DATEB
- DO DD^%DT
- SET ECXEND=Y
- +50 QUIT
- +51 ;
- DEVICE(ZTRTN,ZTDESC,ZTSAVE) ;get print device and optionally task to background
- +1 ; input
- +2 ; ZTRTN = line^routine; task entry point (required)
- +3 ; variable for %ZTLOAD
- +4 ; ZTDESC = task description (required)
- +5 ; variable for %ZTLOAD
- +6 ; ZTSAVE = array; passed by reference (required)
- +7 ; variables for %ZTLOAD
- +8 ; output
- +9 ; ZTSAVE = returns ZTSAVE("POP"),ZTSAVE("ZTSK")
- +10 ;
- +11 NEW POP,ZTSK
- +12 SET ZTSAVE("POP")=0
- SET ZTSAVE("ZTSK")=0
- +13 ;return ztsave("pop")=1 and quit if required input not available
- +14 IF '$LENGTH(ZTRTN)!('$LENGTH(ZTDESC))!('$DATA(ZTSAVE))
- SET ZTSAVE("POP")=1
- QUIT
- +15 ;get print device
- +16 KILL IO("Q")
- SET %ZIS="QM"
- DO ^%ZIS
- +17 SET ZTSAVE("POP")=POP
- +18 IF POP
- Begin DoDot:1
- +19 WRITE !,"No device selected...exiting.",!
- End DoDot:1
- +20 if POP
- QUIT
- +21 IF $DATA(IO("Q"))
- Begin DoDot:1
- +22 SET ZTSAVE("ZTREQ")="@"
- +23 DO ^%ZTLOAD
- +24 IF $GET(ZTSK)>0
- Begin DoDot:2
- +25 WRITE !,"Request queued as Task #",ZTSK,".",!
- +26 SET ZTSAVE("ZTSK")=ZTSK
- +27 SET ZTSAVE("POP")=0
- End DoDot:2
- +28 IF '$GET(ZTSK)
- Begin DoDot:2
- +29 WRITE !,"Request to queue cancelled...exiting.",!
- +30 SET ZTSAVE("ZTSK")=0
- +31 SET ZTSAVE("POP")=1
- End DoDot:2
- End DoDot:1
- +32 QUIT
- +33 ;
- WARDS(ECXALL,ECXDIV) ;get wards for selected divisions
- +1 ; input
- +2 ; ECXALL = 1/0 (optional)
- +3 ; 1==> user selected all divisions OR
- +4 ; facility is non-divisional
- +5 ; 0==> user selected some divisions
- +6 ; if ECXALL not defined, then assume 1
- +7 ; ECXDIV = array of divisions selected (optional)
- +8 ; passed by reference array containing
- +9 ; selected divisions;
- +10 ; if ECXALL=1, then ECXDIV array isn't
- +11 ; required; information for all wards will be obtained
- +12 ; if ECXALL=0, then only wards for divisions in ECXDIV
- +13 ; output
- +14 ; ^TMP($J,"ECXWARD", contains ward name, division, g&l order
- +15 ; ^TMP($J,"ECXORDER", contains ward grouping info
- +16 ;
- +17 NEW IEN,WARD,ORDX,NAME,NM,ORDER,DIV,HIEN,GROUP,DATA,DEPT,NAMEDEPT
- +18 KILL ^TMP($JOB,"ECXWARD"),^TMP($JOB,"ECXORDER")
- +19 ;if ecxall not here, then set ecxall=1
- +20 if '$DATA(ECXALL)
- SET ECXALL=1
- if ECXALL=""
- SET ECXALL=1
- +21 SET ORDX=0
- SET NM=""
- +22 FOR
- SET NM=$ORDER(^DIC(42,"B",NM))
- if NM=""
- QUIT
- SET IEN=0
- FOR
- SET IEN=$ORDER(^DIC(42,"B",NM,IEN))
- if IEN=""
- QUIT
- Begin DoDot:1
- +23 SET DIV=+$PIECE(^DIC(42,IEN,0),U,11)
- if DIV=0
- QUIT
- +24 IF ECXALL=0
- IF '$DATA(ECXDIV(DIV))
- QUIT
- +25 SET (NAME,ORDER,DEPT)=""
- SET NAME=$PIECE(^DIC(42,IEN,0),U,1)
- SET ORDER=+$PIECE($GET(^DIC(42,IEN,"ORDER")),U,1)
- SET DEPT=$PIECE($GET(^ECX(727.4,IEN,0)),U,2)
- +26 ;'unordered' ward is probably inactive, but get basic data anyway
- +27 IF ORDER=0
- SET ORDX=ORDX+1
- SET ORDER="99999"_ORDX
- SET ORDER=+ORDER
- +28 ;get this ward's ien in file #44; file #727.802 & #727.808 use pointers to file #44
- +29 SET HIEN=+$PIECE($GET(^DIC(42,IEN,44)),U,1)
- if HIEN=0
- QUIT
- +30 ;if this is last ward in group, then get the group name
- +31 KILL GROUP
- IF $DATA(^DIC(42,IEN,1,1,0))
- SET GROUP=$PIECE(^DIC(42,IEN,1,1,0),U,1)
- IF GROUP=""
- KILL GROUP
- +32 SET ^TMP($JOB,"ECXWARD",HIEN)=ORDER_U_NAME_U_DIV_U_IEN_U_DEPT
- +33 IF $DATA(GROUP)
- SET ^TMP($JOB,"ECXWARD",HIEN,1)=GROUP
- End DoDot:1
- +34 ;after all wards in file #42 are processed, arrange by g&l order
- +35 SET HIEN=0
- +36 FOR
- SET HIEN=$ORDER(^TMP($JOB,"ECXWARD",HIEN))
- if HIEN=""
- QUIT
- SET DATA=^TMP($JOB,"ECXWARD",HIEN)
- Begin DoDot:1
- +37 SET ORDER=$PIECE(DATA,U,1)
- SET NAME=$PIECE(DATA,U,2)
- SET DIV=$PIECE(DATA,U,3)
- SET DEPT=$PIECE(DATA,U,5)
- +38 SET NAMEDEPT=NAME
- if DEPT]""
- SET NAMEDEPT=NAME_" <"_DEPT_">"
- +39 SET ^TMP($JOB,"ECXORDER",DIV,ORDER)=HIEN_U_NAMEDEPT_U
- +40 IF $DATA(^TMP($JOB,"ECXWARD",HIEN,1))
- SET GROUP=^(1)
- SET ^TMP($JOB,"ECXORDER",DIV,ORDER,1)=1_U_GROUP_U
- End DoDot:1
- +41 QUIT
- +42 ;
- SASHEAD(ECXFL,ECXHEAD,ECXDIV,ECXARRAY,ECXPG,ECXTAB) ;header and page control
- +1 ;
- +2 ; ECXFL = feeder location (division) (required)
- +3 ; ECXHEAD = extract header from file #727.1 (required)
- +4 ; ECXDIV = array of divisions selected (required)
- +5 ; ECXPG = page number (required)
- +6 ; ECXTAB = tab location;
- +7 ; allows for proper spacing in sub-header line (optional)
- +8 ;
- +9 NEW JJ,SS,LN
- +10 SET $PIECE(LN,"-",80)=""
- +11 IF $GET(ECXTAB)=""
- SET ECXTAB=40
- +12 IF $EXTRACT(IOST)="C"
- Begin DoDot:1
- +13 SET SS=22-$Y
- FOR JJ=1:1:SS
- WRITE !
- +14 IF PG>0
- SET DIR(0)="E"
- WRITE !
- DO ^DIR
- KILL DIR
- if 'Y
- SET QFLG=1
- End DoDot:1
- +15 if QFLG
- QUIT
- +16 if $Y!($EXTRACT(IOST)="C")
- WRITE @IOF
- SET ECXPG=ECXPG+1
- +17 WRITE !,"SAS Audit Report for "_ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract"
- +18 WRITE !,"DSS Extract Log #: "_ECXARRAY("EXTRACT")
- +19 WRITE !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
- +20 WRITE !,"Report Run Date/Time: "_ECXRUN
- +21 IF $DATA(ECXDIV(ECXFL))
- WRITE !,"Division/Site: "_$PIECE(ECXDIV(ECXFL),U,2)_" ("_ECXFL_")",?68,"Page: "_ECXPG
- +22 IF '$DATA(ECXDIV(ECXFL))
- WRITE !,"Division/Site: "_"Unknown",?68,"Page: "_ECXPG
- +23 ;161 Special header for SUR only
- IF ECXHEAD="SUR"
- WRITE !!,"Feeder",?12,"Feeder Location",!,"Location",?12,"Name",?ECXTAB,"Feeder Key",?68,"Quantity"
- +24 ;161 Non-SUR report header
- IF ECXHEAD'="SUR"
- WRITE !!,"Feeder Location",?ECXTAB,"Feeder Key",?68,"Quantity"
- +25 WRITE !,LN,!
- +26 QUIT
- +27 ;
- RUN ;154 Section allows extract to be run from within audit report
- +1 NEW DIR,X,Y,DTOUT,DUOUT,ECPACK,ECGRP,ECFILE,ECRTN,ECPIECE,ECVER,ECHEAD,ECXAUDIT
- +2 WRITE !
- +3 SET DIR("A",1)="You didn't select an existing extract log record number. Remember"
- +4 SET DIR("A",2)="the extract must be run first, before you can run this audit."
- +5 SET DIR("A",3)="If there is no log record number, run the extract from the Package Extracts"
- +6 SET DIR("A",4)="menu or if unavailable there, from here (you will be prompted to"
- +7 SET DIR("A",5)="queue the extract below)."
- +8 SET DIR("A",6)=""
- +9 SET DIR("A",7)="Remember that if you queue the extract to run from here"
- +10 SET DIR("A",8)="(the extract audit report menu), you may have to wait overnight for the"
- +11 SET DIR("A",9)="extract to finish. It must finish before you can pick its log record number"
- +12 SET DIR("A",10)="to run the extract audit."
- +13 SET DIR("A",11)=""
- +14 SET DIR("A")="Would you like to queue the "_ECXHEAD_" extract"
- +15 SET DIR(0)="Y"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- +16 if Y'=1
- QUIT
- +17 SET ECHEAD=ECXHEAD
- SET ECXAUDIT=1
- +18 DO ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
- +19 IF ECFILE=""
- QUIT
- +20 DO ^ECXTRAC
- DO ^ECXKILL
- +21 QUIT