Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AGRPTEMP

AGRPTEMP.m

Go to the documentation of this file. 
  1. AGRPTEMP ;IHS/SD/TPF - LIST EMPLOYEES BY EMPLOYER
  1.  ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
  1.  ;
  1.  ;ABILITY TO LIST EMPLOYEES BY EMPLOYER.
  1.  ;
  1. EN ;EP
  1.  K EXCLSION
  1.  S $P(AGLINE("EQ"),"=",81)=""
  1.  S $P(AGLINE("-"),"-",81)=""
  1.  W !,"This program generates a listing of the Employees for each Employer, sorted in alphabetical order."
  1.  W !!
  1.  K DIR
  1.  S DIR("A")="Do you wish the Run the Program"
  1.  S DIR("B")="Y"
  1.  S DIR(0)="YO"
  1.  D ^DIR
  1.  Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))
  1.  Q:'Y
  1.  K DIR
  1.  D MAIN    ;MAIN SLECTION DRIVER
  1.  D EXIT    ;CLEANUP VARS
  1.  Q
  1. MAIN ;MAIN SELECTION DRIVER
  1.  K ^XTMP("AGRPTEMP",$J),PRINTOUT
  1.  D EXCHDR  ;PRINT EXCLUSION PARAMETERS CHOSEN BY USER
  1.  N TAG
  1.  K DIR
  1.  S DIR("A")="Select ONE or MORE of the above EXCLUSION PARAMETERS"
  1.  S DIR(0)="SO^1:EMP;2:STAT"
  1.  S DIR("L",1)="Select one of the following:"
  1.  S DIR("L",2)=""
  1.  S DIR("L",3)="     1  EMPLOYER"
  1.  S DIR("L",4)="             ALL EMPLOYERS"
  1.  S DIR("L",5)="             SPECIFIC EMPLOYERS (enter specific names or from to)"
  1.  S DIR("L",6)="     2  EMPLOYMENT STATUS"
  1.  S DIR("L")="              Select Employment Status"
  1.  D ^DIR
  1.  I X="" D DOSORT(.EXCLSION),DOPRINT("") G MAIN
  1.  Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))
  1.  S TAG="ASK"_Y(0)
  1.  D @TAG
  1.  K TAG
  1.  G MAIN
  1.  Q
  1. ASKEMP ;ASK FOR EMPLOYERS
  1.  N TAG
  1.  K EXCLSION("Employers")
  1.  K DIR
  1.  S DIR("A")="Choose one"
  1.  S DIR("B")="A"
  1.  S DIR(0)="SO^A:ALL;S:SPECIFIC NAMES;F:FROM/TO"
  1.  D ^DIR
  1.  Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))
  1.  S TAG="EMP"_Y
  1.  D @TAG
  1.  K TAG,DIR
  1.  Q
  1. ASKDATES ;ASK FOR DATE RANGES
  1.  K DIR,DTOUT,DUOUT,DIRUT,DIROUT
  1.  S DIR("A")="Effective Date"
  1.  S:$D(EXCLSION("Effective Date")) DIR("B")=EXCLSION("Effective Date")
  1.  S DIR(0)="DO"
  1.  D ^DIR
  1.  I X="@" K EXCLSION("Effective Date") W "Deleted"
  1.  Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))
  1.  S EFFDATE=$G(Y)
  1.  S EXCLSION("Effective Date")=EFFDATE
  1.  K DIR
  1.  S DIR("A")="Termination Date"
  1.  S:$D(EXCLSION("Termination Date")) DIR("B")=EXCLSION("Termination Date")
  1.  S DIR(0)="DO"
  1.  D ^DIR
  1.  I X="@" K EXCLSION("Effective Date") W "Deleted"
  1.  Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))
  1.  S TERMDATE=$G(Y)
  1.  S EXCLSION("Termination Date")=TERMDATE
  1.  K:EXCLSION("Termination Date")="" EXCLSION("Termination Date")
  1.  Q
  1. ASKSTAT ;ASK FOR STATUS FULL,PART ETC
  1.  N CODES
  1.  K DIR
  1.  S CODES=$P($G(^DD(9000001,.21,0)),U,3)
  1.  S DIR("A")="Employment Status"
  1.  S DIR(0)="SO"_U_CODES_"A:ALL"
  1.  D ^DIR
  1.  Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))
  1.  S EMPSTAT=Y(0)
  1.  S EXCLSION("Employment Status")=Y_U_Y(0)
  1.  K:EXCLSION("Employment Status")="" EXCLSION("Employment Status")
  1.  Q
  1. EMPA ;DO ALL EMPLOYERS
  1.  W !,"YOU CHOSE DO ALL EMPLOYERS"
  1.  S EXCLSION("Employers")="ALL"
  1.  Q
  1. EMPS ;ALLOW SELECTION OF SPECIFIC EMPLOYERS
  1.  W !,"YOU CHOSE TO DO SPECIFIC EMPLOYERS"
  1.  S EXCLSION("Employers")="SPECIFIC EMPLOYERS"
  1. EMPS1 K DIR,DTOUT,DUOUT,DIRUT,DIROUT
  1.  S DIR(0)="PO^9999999.75:AEM"
  1.  D ^DIR
  1.  Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))
  1.  I X="@" K EXCLSION("Employers") Q
  1.  Q:X=""
  1.  S EXCLSION("Employers",+Y)=Y
  1.  G:+Y EMPS1
  1.  Q
  1. EMPF ;ALLOW SELECTION OF FROM/TO EMPLOYERS
  1.  W !,"YOU CHOSE TO ENTER A RANGE OF EMPLOYERS"
  1.  S EXCLSION("Employers")="RANGE OF EMPLOYERS"
  1.  S COUNT=0
  1. FROM K DIR,DTOUT,DUOUT,DIRUT,DIROUT
  1.  S COUNT=COUNT+1
  1.  W !
  1.  S DIR("A")="From Employer"
  1.  S DIR(0)="PO^9999999.75:AEM"
  1.  D ^DIR
  1.  Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))
  1.  I X="@" K EXCLSION("Employers") Q
  1.  Q:X=""
  1.  S EXCLSION("Employers",COUNT)=Y
  1. TO K DIR,DTOUT,DUOUT,DIRUT,DIROUT
  1.  W !
  1.  S DIR("A")="To Employer"
  1.  S DIR(0)="PO^9999999.75:AEM"
  1.  D ^DIR
  1.  Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))
  1.  I X'="",($P(Y,U,2)']$P(EXCLSION("Employers",COUNT),U,2)) W "      Incorrect from/to sequence!" G TO
  1.  S $P(EXCLSION("Employers",COUNT),"|",2)=Y
  1.  G FROM
  1.  Q
  1. EXCHDR ;EP
  1.  I '$D(PRINTOUT) W @IOF
  1.  I $G(EXCLSION("Employers"))="" S EXCLSION("Employers")="ALL"
  1.  I $G(EXCLSION("Employment Status"))="" S EXCLSION("Employment Status")="A^ALL"
  1.  I '$D(EXCLSION) W !,"NO EXCLUSION PARAMETERS CURRENTLY IN EFFECT" Q
  1.  W !,"EXCLUSION PARAMETERS Currently in Effect for RESTRICTING the REPORT to:"
  1.  W !,AGLINE("EQ")
  1.  W:$G(EXCLSION("Employment Status"))'="" !,"- Employment Status.......: ",$P($G(EXCLSION("Employment Status")),U,2)
  1.  W:$G(EXCLSION("Effective Date"))'="" !,"- Effective Date..........: ",$G(EXCLSION("Effective Date"))
  1.  W:$G(EXCLSION("Termination Date"))'="" !,"- Termination Date..........: ",$G(EXCLSION("Termination Date"))
  1.  I $D(EXCLSION("Employers")) D
  1.  .W !,"- Employers: "
  1.  .I $P(EXCLSION("Employers"),U)="SPECIFIC EMPLOYERS" D  Q
  1.  ..W "SPECIFIC EMPLOYERS: "
  1.  ..S EMPREC=""
  1.  ..F LN=1:1 S EMPREC=$O(EXCLSION("Employers",EMPREC)) Q:EMPREC=""  D
  1.  ...W @$S(LN'=1:"!?35",1:"?35"),$P(EXCLSION("Employers",EMPREC),U,2)
  1.  .;
  1.  .I $P(EXCLSION("Employers"),U)="RANGE OF EMPLOYERS" D  Q
  1.  ..W "RANGE OF EMPLOYERS: "
  1.  ..S EMPREC=""
  1.  ..F LN=1:1 S EMPREC=$O(EXCLSION("Employers",EMPREC)) Q:EMPREC=""  D
  1.  ...W @$S(LN'=1:"!?35",1:"?35"),"From ",$P($P(EXCLSION("Employers",EMPREC),"|"),U,2)," to ",$P($P(EXCLSION("Employers",EMPREC),"|",2),U,2)
  1.  .W "ALL EMPLOYERS"
  1.  Q
  1. DOSORT(EXCLSION) ;EP - PRINT EMPLOYEES FOR EMPLOYERS SELECTED
  1.  S EMPLECNT=0,EMPLRCNT=0
  1.  I $G(EXCLSION("Employers"))="ALL" D LOOP("",999999999999999)  ;DO ALL EMPLOYERS
  1.  I $G(EXCLSION("Employers"))="SPECIFIC EMPLOYERS" D
  1.  .S EMPREC=""
  1.  .F  S EMPREC=$O(EXCLSION("Employers",EMPREC)) Q:EMPREC=""  D
  1.  ..D LOOP(EMPREC-1,EMPREC+1)
  1.  I $G(EXCLSION("Employers"))="RANGE OF EMPLOYERS" D
  1.  .S EMPREC=""
  1.  .F  S EMPREC=$O(EXCLSION("Employers",EMPREC)) Q:EMPREC=""  D
  1.  ..S EMPLRBEG=$P($P(EXCLSION("Employers",EMPREC),"|"),U,2)
  1.  ..S EMPLRBEG=$E(EMPLRBEG,1,$L(EMPLRBEG)-1)_$C($A($E(EMPLRBEG,$L(EMPLRBEG)))-1)
  1.  ..S EMPLREND=$P($P(EXCLSION("Employers",EMPREC),"|",2),U,2)
  1.  ..F  S EMPLRBEG=$O(^AUTNEMPL("B",EMPLRBEG)) Q:EMPLRBEG]EMPLREND  D
  1.  ...S EMPLRREC=0
  1.  ...F  S EMPLRREC=$O(^AUTNEMPL("B",EMPLRBEG,EMPLRREC)) Q:EMPLRREC=""  D
  1.  ....D LOOP(EMPLRREC-1,EMPLRREC+1)
  1.  Q
  1. LOOP(TAREMPLR,ENDEMPLR) ;EP
  1.  F  S TAREMPLR=$O(^AUPNPAT("AF",TAREMPLR)) Q:TAREMPLR>ENDEMPLR  Q:TAREMPLR=""  D
  1.  .S EMPLRCNT=EMPLRCNT+1
  1.  .S EMPLEE=""
  1.  .F  S EMPLEE=$O(^AUPNPAT("AF",TAREMPLR,EMPLEE)) Q:EMPLEE=""  D
  1.  ..S STATUS=$P($G(^AUPNPAT(EMPLEE,0)),U,21)
  1.  ..I $G(EXCLSION("Employment Status"))'="",$P($G(EXCLSION("Employment Status")),U,2)'="ALL" Q:STATUS'=+$G(EXCLSION("Employment Status"))
  1.  ..S HRN=$P($G(^AUPNPAT(EMPLEE,41,DUZ(2),0)),U,2)
  1.  ..S EMPLEENM=$E($P($G(^DPT(EMPLEE,0)),U),1,15)
  1.  ..S:EMPLEENM="" EMPLEENM="UNDEFINED"
  1.  ..S EMPLRNM=$E($P($G(^AUTNEMPL(TAREMPLR,0)),U),1,15)
  1.  ..S:EMPLRNM="" EMPLRNM="UNDEFINED"
  1.  ..S STATUS=$P($P($P(^DD(9000001,.21,0),U,3),";",STATUS),":",2)
  1.  ..S EMPLECNT=EMPLECNT+1
  1.  ..S ^XTMP("AGRPTEMP",$J,EMPLRNM,EMPLEENM)=STATUS_U_HRN
  1.  ..S ^XTMP("AGRPTEMP",$J,"EMPLOYER TOTAL")=EMPLRCNT
  1.  ..S ^XTMP("AGRPTEMP",$J,"EMPLOYEE TOTAL")=EMPLECNT
  1.  Q
  1. DOPRINT(GLO) ;PRINT OUT SORTED TEMP GLOBAL
  1.  I '$D(^XTMP("AGRPTEMP",$J)) W !,"NO RECORDS FOUND!" H 3 Q
  1.  W !,^XTMP("AGRPTEMP",$J,"EMPLOYEE TOTAL")," RECORDS MET THE CRITERIA"
  1.  D ^%ZIS Q:POP
  1.  U IO
  1.  S ESCAPE=0,PAGENO=0
  1.  D HDR
  1.  S EMPLECNT=^XTMP("AGRPTEMP",$J,"EMPLOYEE TOTAL")
  1.  S EMPLRCNT=^XTMP("AGRPTEMP",$J,"EMPLOYER TOTAL")
  1.  S EMPLRNM="EMPLOYER TOTAL"
  1.  F EMPLRREC=1:1 S EMPLRNM=$O(^XTMP("AGRPTEMP",$J,EMPLRNM)) Q:EMPLRNM=""!(ESCAPE)  D
  1.  .D HDR
  1.  .S EMPLEENM=""
  1.  .W !,$E(EMPLRNM,1,15)
  1.  .S LINEITEM=0
  1.  .F EMPLEREC=1:1 S EMPLEENM=$O(^XTMP("AGRPTEMP",$J,EMPLRNM,EMPLEENM)) Q:EMPLEENM=""!(ESCAPE)  D
  1.  ..S STATUS=$P(^XTMP("AGRPTEMP",$J,EMPLRNM,EMPLEENM),U)
  1.  ..S HRN=$P(^XTMP("AGRPTEMP",$J,EMPLRNM,EMPLEENM),U,2)
  1.  ..S LINEITEM=LINEITEM+1
  1.  ..W @$S(LINEITEM=1:"?20",1:"!?20"),$E(EMPLEENM,1,15),?40,HRN,?50,$P(STATUS,U)
  1.  ..;NOTE: HEADER IS 10 LINES
  1.  ..I $Y>(IOSL-10),(IOST[("C-")) W ! K DIR S DIR(0)="E" D ^DIR S ESCAPE=X=U D:'ESCAPE HDR W !,$E(EMPLRNM,1,15) Q
  1.  ..I $Y>(IOSL-10) D HDR W !,$E(EMPLRNM,1,15)
  1.  .W !?20,"========================"
  1.  .W !?20,EMPLEREC-1
  1.  W !!,"Number of Employers        Number of Employees"
  1.  W !,EMPLRCNT,?25,EMPLECNT
  1.  I (IOST[("C-")) K DIR W ! K DIR S DIR(0)="E" D ^DIR S ESCAPE=X=U D:'ESCAPE HDR Q
  1.  D ^%ZISC
  1.  Q
  1. HDR ;MAIN HEADER
  1.  S PRINTOUT=1
  1.  W @IOF
  1.  W !,"WARNING: Confidential Patient Information, Privacy Act Applies"
  1.  W !,AGLINE("EQ")
  1.  D EXCHDR
  1.  W !,AGLINE("EQ")
  1.  W !,"Employer",?20,"Employee",?40,"HRN",?50,"Status"
  1.  W !,AGLINE("-")
  1.  S LINEITEM=0
  1.  Q
  1. EXIT ;EP - CLEANUP VARS
  1.  K EFFDATE,EMPLECNT,COUNT,EMPLEE,EMPLEENM,EMPLEREC,EMPLRBEG,EMPLRCNT,EMPLREND
  1.  K EMPLRNM,EMPLRREC,EMPREC
  1.  Q