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

PXRMGECO.m

Go to the documentation of this file. 
  1. PXRMGECO ;SLC/JVS GEC-Prompts Cont'd ;6/19/03  20:56
  1.  ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  1.  Q
  1.  ;^DISV(  = DBIA #510
  1.  N POP,DIROUT,DIRUT,DUOUT,LOCNP,MENU,PROV,Y
  1.  N DETAIL,FORMAT
  1.  ;
  1. SUM ;#8 Start of Summary (Scoring) report
  1.  ;
  1. SUMBDT D BDT^PXRMGECP Q:$D(DIROUT)!($D(DIRUT))
  1. SUMEDT D EDT^PXRMGECP Q:$D(DIROUT)  I $D(DIRUT) K DIRUT G SUMBDT
  1. SUMPAT D PAT^PXRMGECP Q:$D(DIROUT)  I $D(DIRUT) K DIRUT G SUMEDT
  1. SUMFOR D FOR^PXRMGECP Q:$D(DIROUT)  I $D(DIRUT) K DIRUT G SUMPAT
  1. SUMIOO D SUMIO Q:$D(DIROUT)
  1.  Q
  1. SUMIO ;=====Select IO device
  1.  N %ZIS
  1.  S %ZIS="QM" D ^%ZIS
  1.  I POP Q
  1.  I $D(IO("Q")) D
  1.  .S ZTRTN="SUM^PXRMGECM"
  1.  .S ZTDESC="GEC SUMMARY(SCORING) REPORT"
  1.  .S ZTSAVE("*")=""
  1.  .D ^%ZTLOAD
  1.  ;=====Call Report
  1.  E  D SUM^PXRMGECN
  1.  D HOME^%ZIS
  1.  D ^%ZISC
  1.  S:'$D(DIRUT)&('$D(DUOUT))&('$D(DIROUT)) DIR(0)="E" D ^DIR K DIR(0),Y
  1.  Q
  1.  ;
  1. RS ;#7 Start List and array of GEC Categories
  1.  ;
  1.  N CAT,CATNA,CNT,STAY,NUM,CATIEN,CATARY,BDT,EDT,CATDA
  1.  N SYN,IEN,RPT7
  1.  W @IOF
  1.  W "GEC Referral Service Categories"
  1.  S CNT=0
  1.  S SYN="GECFC" F  S SYN=$O(^AUTTHF("D",SYN)) Q:SYN'["GECFC"  D
  1.  .S IEN=0 F  S IEN=$O(^AUTTHF("D",SYN,IEN)) Q:IEN=""  D
  1.  ..Q:$P($G(^AUTTHF(IEN,0)),"^",11)=1
  1.  ..;
  1.  ..S CATNA=$P($P($G(^AUTTHF(IEN,0)),"^",1)," ",3,7)
  1.  ..S CATARY(CATNA,IEN)=""
  1.  S CATNA="" F  S CATNA=$O(CATARY(CATNA)) Q:CATNA=""  D
  1.  .S CAT=$O(CATARY(CATNA,0))
  1.  .S CNT=CNT+1
  1.  .S CATDA(CNT,CAT)=""
  1.  .W:CNT#2=1 !,CNT,?4,CATNA
  1.  .W:CNT#2=0 ?35,CNT,?39,CATNA
  1.  ;
  1. RSSC ;=====Select Referred Service Categories
  1.  W !
  1.  S DIR("A",1)="Select Categories from the list above using"
  1.  S DIR("A",2)="Commas and/or Dashes for ranges of numbers."
  1.  S DIR("A")="Select Categories or ^ to exit"
  1.  I $D(^DISV(DUZ,"PXRMGEC","RSSC")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","RSSC"))
  1.  S DIR(0)="L^1:"_CNT
  1.  D ^DIR
  1.  K DIR("A"),DIR("B"),DIR(0)
  1.  Q:$D(DIROUT)
  1.  Q:$D(DIRUT)
  1.  S ^DISV(DUZ,"PXRMGEC","RSSC")=X
  1.  N LEN,IME,MEY
  1.  S LEN=$L(Y,",")
  1.  S MEY=0 F IME=1:1:LEN-1 S MEY=$P(Y,",",IME) D
  1.  .S CATMEY(MEY)=""
  1.  S STAY=0 F  S STAY=$O(CATDA(STAY)) Q:STAY=""  D
  1.  .I '$D(CATMEY(STAY)) K CATDA(STAY)
  1.  S NUM=0 F  S NUM=$O(CATDA(NUM)) Q:NUM=""  D
  1.  .S CATIEN($O(CATDA(NUM,0)))=""
  1.  K CATDA,CATMEY
  1. RSBDT D BDT^PXRMGECP Q:$D(DIROUT)!$D(DIRUT)
  1. RSEDT D EDT^PXRMGECP Q:$D(DIROUT)  I $D(DIRUT) K DIRUT G RSBDT
  1. RSPAT D PAT^PXRMGECP Q:$D(DIROUT)  I $D(DIRUT) K DIRUT G RSEDT
  1. RSFOR D FOR^PXRMGECP Q:$D(DIROUT)  I $D(DIRUT) K DIRUT G RSPAT
  1. RSIOO S RPT7=1 D CATIO^PXRMGECP Q:$D(DIROUT)
  1.  Q
  1.  ;
  1.  ;================================================================
  1. LOC ;By Location in the Hospital
  1. LOCDIC ;====Select Location
  1.  ;DBIA #10040 Supported
  1.  N Y,DIC
  1.  S DIC="^SC("
  1.  S DIC(0)="QAMEZ"
  1.  D ^DIC
  1.  I Y>0 S LOCNP=$P(Y(0),"^",1)
  1.  K DIC,DIC(0),Y
  1.  Q
  1.  ;
  1. LOCDIR ;  #5 Start of Location Report
  1.  ;--Returns LOCNP equal to Location Name
  1.  N BDT,EDT
  1.  W @IOF
  1.  K DIR
  1.  I $D(^DISV(DUZ,"PXRMGEC","LOCDIR")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","LOCDIR"))
  1.  S DIR(0)="S^A:All Locations;S:Single Location"
  1.  D ^DIR
  1.  K DIR("A"),DIR("B"),DIR(0)
  1.  Q:$D(DIRUT)!($D(DUOUT))
  1.  Q:$D(DIROUT)
  1.  S ^DISV(DUZ,"PXRMGEC","LOCDIR")=X
  1.  I Y="A" S LOCNP=1
  1.  I Y="S" D LOCDIC
  1.  ;
  1. LOCBDT D BDT^PXRMGECP Q:$D(DIROUT)!($D(DIRUT))
  1. LOCEDT D EDT^PXRMGECP Q:$D(DIROUT)  I $D(DIRUT) K DIRUT G LOCBDT
  1. LOCFOR D FOR^PXRMGECP Q:$D(DIROUT)  I $D(DIRUT) K DIRUT G LOCEDT
  1. LOCIOO D LOCIO Q:$D(DIROUT)
  1.  Q
  1. LOCIO ;=====Select IO device
  1.  N %ZIS
  1.  S %ZIS="QM" D ^%ZIS
  1.  I POP Q
  1.  I $D(IO("Q")) D
  1.  .S ZTRTN="LOC^PXRMGECQ"
  1.  .S ZTDESC="GEC LOCATION REPORT"
  1.  .S ZTSAVE("*")=""
  1.  .D ^%ZTLOAD
  1.  ;=====Call Report
  1.  E  D LOC^PXRMGECR
  1.  D HOME^%ZIS
  1.  D ^%ZISC
  1.  S:'$D(DIRUT)&('$D(DUOUT))&('$D(DIROUT)) DIR(0)="E" D ^DIR K DIR(0),Y
  1.  Q
  1.  ;
  1. CT ; #6 Start Referral Count Totals
  1.  ; makes 4 different reports
  1.  ;
  1.  N SOR
  1. CTSOR D SOR Q:$D(DIROUT)!($D(DIRUT))
  1. CTBDT D BDT^PXRMGECP Q:$D(DIROUT)  I $D(DIRUT) K DIRUT G CTSOR
  1. CTEDT D EDT^PXRMGECP Q:$D(DIROUT)  I $D(DIRUT) K DIRUT G CTBDT
  1. CTFOR D FOR^PXRMGECP Q:$D(DIROUT)  I $D(DIRUT) K DIRUT G CTEDT
  1. CTIOO D CTIO Q:$D(DIROUT)
  1.  Q
  1.  ;
  1. SOR ;======Sort Type
  1.  ;--Return SOR as Type of report
  1.  S DIR("A")="Select Sort Type or ^ to exit"
  1.  I $D(^DISV(DUZ,"PXRMGEC","SOR")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","SOR"))
  1.  S DIR(0)="S^PA:Patient;PR:Provider;L:Location;D:Date"
  1.  D ^DIR
  1.  K DIR("A"),DIR("B"),DIR(0)
  1.  Q:$D(DIRUT)!($D(DIROUT))
  1.  S ^DISV(DUZ,"PXRMGEC","SOR")=X
  1.  S SOR=Y
  1.  Q
  1.  ;
  1. CTIO ;=====Select IO device
  1.  N %ZIS
  1.  S %ZIS="QM" D ^%ZIS
  1.  I POP Q
  1.  ;=====Call Report
  1.  I SOR="PA" D
  1.  .I $D(IO("Q")) D
  1.  ..S ZTRTN="CTP^PXRMGECT"
  1.  ..S ZTDESC="GEC COUNT TOTALS REPORTS"
  1.  ..S ZTSAVE("*")=""
  1.  ..D ^%ZTLOAD
  1.  .E  D CTP^PXRMGECS
  1.  I SOR="PR" D
  1.  .I $D(IO("Q")) D
  1.  ..S ZTRTN="CTDR^PXRMGECT"
  1.  ..S ZTDESC="GEC COUNT TOTALS REPORTS"
  1.  ..S ZTSAVE("*")=""
  1.  ..D ^%ZTLOAD
  1.  .E  D CTDR^PXRMGECS
  1.  I SOR="L" D
  1.  .I $D(IO("Q")) D
  1.  ..S ZTRTN="CTL^PXRMGECT"
  1.  ..S ZTDESC="GEC COUNT TOTALS REPORTS"
  1.  ..S ZTSAVE("*")=""
  1.  ..D ^%ZTLOAD
  1.  .E  D CTL^PXRMGECS
  1.  I SOR="D" D
  1.  .I $D(IO("Q")) D
  1.  ..S ZTRTN="CTD^PXRMGECT"
  1.  ..S ZTDESC="GEC COUNT TOTALS REPORTS"
  1.  ..S ZTSAVE("*")=""
  1.  ..D ^%ZTLOAD
  1.  .E  D CTD^PXRMGECS
  1.  D ^%ZISC
  1.  S:'$D(DIRUT)&('$D(DUOUT))&('$D(DIROUT)) DIR(0)="E" D ^DIR K DIR(0),Y
  1.  Q
  1.  ;