PXRMGECO ;SLC/JVS GEC-Prompts Cont'd ;6/19/03 20:56
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
Q
;^DISV( = DBIA #510
N POP,DIROUT,DIRUT,DUOUT,LOCNP,MENU,PROV,Y
N DETAIL,FORMAT
;
SUM ;#8 Start of Summary (Scoring) report
;
SUMBDT D BDT^PXRMGECP Q:$D(DIROUT)!($D(DIRUT))
SUMEDT D EDT^PXRMGECP Q:$D(DIROUT) I $D(DIRUT) K DIRUT G SUMBDT
SUMPAT D PAT^PXRMGECP Q:$D(DIROUT) I $D(DIRUT) K DIRUT G SUMEDT
SUMFOR D FOR^PXRMGECP Q:$D(DIROUT) I $D(DIRUT) K DIRUT G SUMPAT
SUMIOO D SUMIO Q:$D(DIROUT)
Q
SUMIO ;=====Select IO device
N %ZIS
S %ZIS="QM" D ^%ZIS
I POP Q
I $D(IO("Q")) D
.S ZTRTN="SUM^PXRMGECM"
.S ZTDESC="GEC SUMMARY(SCORING) REPORT"
.S ZTSAVE("*")=""
.D ^%ZTLOAD
;=====Call Report
E D SUM^PXRMGECN
D HOME^%ZIS
D ^%ZISC
S:'$D(DIRUT)&('$D(DUOUT))&('$D(DIROUT)) DIR(0)="E" D ^DIR K DIR(0),Y
Q
;
RS ;#7 Start List and array of GEC Categories
;
N CAT,CATNA,CNT,STAY,NUM,CATIEN,CATARY,BDT,EDT,CATDA
N SYN,IEN,RPT7
W @IOF
W "GEC Referral Service Categories"
S CNT=0
S SYN="GECFC" F S SYN=$O(^AUTTHF("D",SYN)) Q:SYN'["GECFC" D
.S IEN=0 F S IEN=$O(^AUTTHF("D",SYN,IEN)) Q:IEN="" D
..Q:$P($G(^AUTTHF(IEN,0)),"^",11)=1
..;
..S CATNA=$P($P($G(^AUTTHF(IEN,0)),"^",1)," ",3,7)
..S CATARY(CATNA,IEN)=""
S CATNA="" F S CATNA=$O(CATARY(CATNA)) Q:CATNA="" D
.S CAT=$O(CATARY(CATNA,0))
.S CNT=CNT+1
.S CATDA(CNT,CAT)=""
.W:CNT#2=1 !,CNT,?4,CATNA
.W:CNT#2=0 ?35,CNT,?39,CATNA
;
W !
S DIR("A",1)="Select Categories from the list above using"
S DIR("A",2)="Commas and/or Dashes for ranges of numbers."
S DIR("A")="Select Categories or ^ to exit"
I $D(^DISV(DUZ,"PXRMGEC","RSSC")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","RSSC"))
S DIR(0)="L^1:"_CNT
D ^DIR
K DIR("A"),DIR("B"),DIR(0)
Q:$D(DIROUT)
Q:$D(DIRUT)
S ^DISV(DUZ,"PXRMGEC","RSSC")=X
N LEN,IME,MEY
S LEN=$L(Y,",")
S MEY=0 F IME=1:1:LEN-1 S MEY=$P(Y,",",IME) D
.S CATMEY(MEY)=""
S STAY=0 F S STAY=$O(CATDA(STAY)) Q:STAY="" D
.I '$D(CATMEY(STAY)) K CATDA(STAY)
S NUM=0 F S NUM=$O(CATDA(NUM)) Q:NUM="" D
.S CATIEN($O(CATDA(NUM,0)))=""
K CATDA,CATMEY
RSBDT D BDT^PXRMGECP Q:$D(DIROUT)!$D(DIRUT)
RSEDT D EDT^PXRMGECP Q:$D(DIROUT) I $D(DIRUT) K DIRUT G RSBDT
RSPAT D PAT^PXRMGECP Q:$D(DIROUT) I $D(DIRUT) K DIRUT G RSEDT
RSFOR D FOR^PXRMGECP Q:$D(DIROUT) I $D(DIRUT) K DIRUT G RSPAT
RSIOO S RPT7=1 D CATIO^PXRMGECP Q:$D(DIROUT)
Q
;
;================================================================
LOC ;By Location in the Hospital
LOCDIC ;====Select Location
;DBIA #10040 Supported
N Y,DIC
S DIC="^SC("
S DIC(0)="QAMEZ"
D ^DIC
I Y>0 S LOCNP=$P(Y(0),"^",1)
K DIC,DIC(0),Y
Q
;
LOCDIR ; #5 Start of Location Report
;--Returns LOCNP equal to Location Name
N BDT,EDT
W @IOF
K DIR
I $D(^DISV(DUZ,"PXRMGEC","LOCDIR")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","LOCDIR"))
S DIR(0)="S^A:All Locations;S:Single Location"
D ^DIR
K DIR("A"),DIR("B"),DIR(0)
Q:$D(DIRUT)!($D(DUOUT))
Q:$D(DIROUT)
S ^DISV(DUZ,"PXRMGEC","LOCDIR")=X
I Y="A" S LOCNP=1
I Y="S" D LOCDIC
;
LOCBDT D BDT^PXRMGECP Q:$D(DIROUT)!($D(DIRUT))
LOCEDT D EDT^PXRMGECP Q:$D(DIROUT) I $D(DIRUT) K DIRUT G LOCBDT
LOCFOR D FOR^PXRMGECP Q:$D(DIROUT) I $D(DIRUT) K DIRUT G LOCEDT
LOCIOO D LOCIO Q:$D(DIROUT)
Q
LOCIO ;=====Select IO device
N %ZIS
S %ZIS="QM" D ^%ZIS
I POP Q
I $D(IO("Q")) D
.S ZTRTN="LOC^PXRMGECQ"
.S ZTDESC="GEC LOCATION REPORT"
.S ZTSAVE("*")=""
.D ^%ZTLOAD
;=====Call Report
E D LOC^PXRMGECR
D HOME^%ZIS
D ^%ZISC
S:'$D(DIRUT)&('$D(DUOUT))&('$D(DIROUT)) DIR(0)="E" D ^DIR K DIR(0),Y
Q
;
CT ; #6 Start Referral Count Totals
; makes 4 different reports
;
N SOR
CTSOR D SOR Q:$D(DIROUT)!($D(DIRUT))
CTBDT D BDT^PXRMGECP Q:$D(DIROUT) I $D(DIRUT) K DIRUT G CTSOR
CTEDT D EDT^PXRMGECP Q:$D(DIROUT) I $D(DIRUT) K DIRUT G CTBDT
CTFOR D FOR^PXRMGECP Q:$D(DIROUT) I $D(DIRUT) K DIRUT G CTEDT
CTIOO D CTIO Q:$D(DIROUT)
Q
;
SOR ;======Sort Type
;--Return SOR as Type of report
S DIR("A")="Select Sort Type or ^ to exit"
I $D(^DISV(DUZ,"PXRMGEC","SOR")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","SOR"))
S DIR(0)="S^PA:Patient;PR:Provider;L:Location;D:Date"
D ^DIR
K DIR("A"),DIR("B"),DIR(0)
Q:$D(DIRUT)!($D(DIROUT))
S ^DISV(DUZ,"PXRMGEC","SOR")=X
S SOR=Y
Q
;
CTIO ;=====Select IO device
N %ZIS
S %ZIS="QM" D ^%ZIS
I POP Q
;=====Call Report
I SOR="PA" D
.I $D(IO("Q")) D
..S ZTRTN="CTP^PXRMGECT"
..S ZTDESC="GEC COUNT TOTALS REPORTS"
..S ZTSAVE("*")=""
..D ^%ZTLOAD
.E D CTP^PXRMGECS
I SOR="PR" D
.I $D(IO("Q")) D
..S ZTRTN="CTDR^PXRMGECT"
..S ZTDESC="GEC COUNT TOTALS REPORTS"
..S ZTSAVE("*")=""
..D ^%ZTLOAD
.E D CTDR^PXRMGECS
I SOR="L" D
.I $D(IO("Q")) D
..S ZTRTN="CTL^PXRMGECT"
..S ZTDESC="GEC COUNT TOTALS REPORTS"
..S ZTSAVE("*")=""
..D ^%ZTLOAD
.E D CTL^PXRMGECS
I SOR="D" D
.I $D(IO("Q")) D
..S ZTRTN="CTD^PXRMGECT"
..S ZTDESC="GEC COUNT TOTALS REPORTS"
..S ZTSAVE("*")=""
..D ^%ZTLOAD
.E D CTD^PXRMGECS
D ^%ZISC
S:'$D(DIRUT)&('$D(DUOUT))&('$D(DIROUT)) DIR(0)="E" D ^DIR K DIR(0),Y
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMGECO 5171 printed Apr 09, 2024@20:54:52 Page 2
PXRMGECO ;SLC/JVS GEC-Prompts Cont'd ;6/19/03 20:56
+1 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+2 QUIT
+3 ;^DISV( = DBIA #510
+4 NEW POP,DIROUT,DIRUT,DUOUT,LOCNP,MENU,PROV,Y
+5 NEW DETAIL,FORMAT
+6 ;
SUM ;#8 Start of Summary (Scoring) report
+1 ;
SUMBDT DO BDT^PXRMGECP
if $DATA(DIROUT)!($DATA(DIRUT))
QUIT
SUMEDT DO EDT^PXRMGECP
if $DATA(DIROUT)
QUIT
IF $DATA(DIRUT)
KILL DIRUT
GOTO SUMBDT
SUMPAT DO PAT^PXRMGECP
if $DATA(DIROUT)
QUIT
IF $DATA(DIRUT)
KILL DIRUT
GOTO SUMEDT
SUMFOR DO FOR^PXRMGECP
if $DATA(DIROUT)
QUIT
IF $DATA(DIRUT)
KILL DIRUT
GOTO SUMPAT
SUMIOO DO SUMIO
if $DATA(DIROUT)
QUIT
+1 QUIT
SUMIO ;=====Select IO device
+1 NEW %ZIS
+2 SET %ZIS="QM"
DO ^%ZIS
+3 IF POP
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTRTN="SUM^PXRMGECM"
+6 SET ZTDESC="GEC SUMMARY(SCORING) REPORT"
+7 SET ZTSAVE("*")=""
+8 DO ^%ZTLOAD
End DoDot:1
+9 ;=====Call Report
+10 IF '$TEST
DO SUM^PXRMGECN
+11 DO HOME^%ZIS
+12 DO ^%ZISC
+13 if '$DATA(DIRUT)&('$DATA(DUOUT))&('$DATA(DIROUT))
SET DIR(0)="E"
DO ^DIR
KILL DIR(0),Y
+14 QUIT
+15 ;
RS ;#7 Start List and array of GEC Categories
+1 ;
+2 NEW CAT,CATNA,CNT,STAY,NUM,CATIEN,CATARY,BDT,EDT,CATDA
+3 NEW SYN,IEN,RPT7
+4 WRITE @IOF
+5 WRITE "GEC Referral Service Categories"
+6 SET CNT=0
+7 SET SYN="GECFC"
FOR
SET SYN=$ORDER(^AUTTHF("D",SYN))
if SYN'["GECFC"
QUIT
Begin DoDot:1
+8 SET IEN=0
FOR
SET IEN=$ORDER(^AUTTHF("D",SYN,IEN))
if IEN=""
QUIT
Begin DoDot:2
+9 if $PIECE($GET(^AUTTHF(IEN,0)),"^",11)=1
QUIT
+10 ;
+11 SET CATNA=$PIECE($PIECE($GET(^AUTTHF(IEN,0)),"^",1)," ",3,7)
+12 SET CATARY(CATNA,IEN)=""
End DoDot:2
End DoDot:1
+13 SET CATNA=""
FOR
SET CATNA=$ORDER(CATARY(CATNA))
if CATNA=""
QUIT
Begin DoDot:1
+14 SET CAT=$ORDER(CATARY(CATNA,0))
+15 SET CNT=CNT+1
+16 SET CATDA(CNT,CAT)=""
+17 if CNT#2=1
WRITE !,CNT,?4,CATNA
+18 if CNT#2=0
WRITE ?35,CNT,?39,CATNA
End DoDot:1
+19 ;
+1 WRITE !
+2 SET DIR("A",1)="Select Categories from the list above using"
+3 SET DIR("A",2)="Commas and/or Dashes for ranges of numbers."
+4 SET DIR("A")="Select Categories or ^ to exit"
+5 IF $DATA(^DISV(DUZ,"PXRMGEC","RSSC"))
SET DIR("B")=$GET(^DISV(DUZ,"PXRMGEC","RSSC"))
+6 SET DIR(0)="L^1:"_CNT
+7 DO ^DIR
+8 KILL DIR("A"),DIR("B"),DIR(0)
+9 if $DATA(DIROUT)
QUIT
+10 if $DATA(DIRUT)
QUIT
+11 SET ^DISV(DUZ,"PXRMGEC","RSSC")=X
+12 NEW LEN,IME,MEY
+13 SET LEN=$LENGTH(Y,",")
+14 SET MEY=0
FOR IME=1:1:LEN-1
SET MEY=$PIECE(Y,",",IME)
Begin DoDot:1
+15 SET CATMEY(MEY)=""
End DoDot:1
+16 SET STAY=0
FOR
SET STAY=$ORDER(CATDA(STAY))
if STAY=""
QUIT
Begin DoDot:1
+17 IF '$DATA(CATMEY(STAY))
KILL CATDA(STAY)
End DoDot:1
+18 SET NUM=0
FOR
SET NUM=$ORDER(CATDA(NUM))
if NUM=""
QUIT
Begin DoDot:1
+19 SET CATIEN($ORDER(CATDA(NUM,0)))=""
End DoDot:1
+20 KILL CATDA,CATMEY
RSBDT DO BDT^PXRMGECP
if $DATA(DIROUT)!$DATA(DIRUT)
QUIT
RSEDT DO EDT^PXRMGECP
if $DATA(DIROUT)
QUIT
IF $DATA(DIRUT)
KILL DIRUT
GOTO RSBDT
RSPAT DO PAT^PXRMGECP
if $DATA(DIROUT)
QUIT
IF $DATA(DIRUT)
KILL DIRUT
GOTO RSEDT
RSFOR DO FOR^PXRMGECP
if $DATA(DIROUT)
QUIT
IF $DATA(DIRUT)
KILL DIRUT
GOTO RSPAT
RSIOO SET RPT7=1
DO CATIO^PXRMGECP
if $DATA(DIROUT)
QUIT
+1 QUIT
+2 ;
+3 ;================================================================
LOC ;By Location in the Hospital
LOCDIC ;====Select Location
+1 ;DBIA #10040 Supported
+2 NEW Y,DIC
+3 SET DIC="^SC("
+4 SET DIC(0)="QAMEZ"
+5 DO ^DIC
+6 IF Y>0
SET LOCNP=$PIECE(Y(0),"^",1)
+7 KILL DIC,DIC(0),Y
+8 QUIT
+9 ;
LOCDIR ; #5 Start of Location Report
+1 ;--Returns LOCNP equal to Location Name
+2 NEW BDT,EDT
+3 WRITE @IOF
+4 KILL DIR
+5 IF $DATA(^DISV(DUZ,"PXRMGEC","LOCDIR"))
SET DIR("B")=$GET(^DISV(DUZ,"PXRMGEC","LOCDIR"))
+6 SET DIR(0)="S^A:All Locations;S:Single Location"
+7 DO ^DIR
+8 KILL DIR("A"),DIR("B"),DIR(0)
+9 if $DATA(DIRUT)!($DATA(DUOUT))
QUIT
+10 if $DATA(DIROUT)
QUIT
+11 SET ^DISV(DUZ,"PXRMGEC","LOCDIR")=X
+12 IF Y="A"
SET LOCNP=1
+13 IF Y="S"
DO LOCDIC
+14 ;
LOCBDT DO BDT^PXRMGECP
if $DATA(DIROUT)!($DATA(DIRUT))
QUIT
LOCEDT DO EDT^PXRMGECP
if $DATA(DIROUT)
QUIT
IF $DATA(DIRUT)
KILL DIRUT
GOTO LOCBDT
LOCFOR DO FOR^PXRMGECP
if $DATA(DIROUT)
QUIT
IF $DATA(DIRUT)
KILL DIRUT
GOTO LOCEDT
LOCIOO DO LOCIO
if $DATA(DIROUT)
QUIT
+1 QUIT
LOCIO ;=====Select IO device
+1 NEW %ZIS
+2 SET %ZIS="QM"
DO ^%ZIS
+3 IF POP
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTRTN="LOC^PXRMGECQ"
+6 SET ZTDESC="GEC LOCATION REPORT"
+7 SET ZTSAVE("*")=""
+8 DO ^%ZTLOAD
End DoDot:1
+9 ;=====Call Report
+10 IF '$TEST
DO LOC^PXRMGECR
+11 DO HOME^%ZIS
+12 DO ^%ZISC
+13 if '$DATA(DIRUT)&('$DATA(DUOUT))&('$DATA(DIROUT))
SET DIR(0)="E"
DO ^DIR
KILL DIR(0),Y
+14 QUIT
+15 ;
CT ; #6 Start Referral Count Totals
+1 ; makes 4 different reports
+2 ;
+3 NEW SOR
CTSOR DO SOR
if $DATA(DIROUT)!($DATA(DIRUT))
QUIT
CTBDT DO BDT^PXRMGECP
if $DATA(DIROUT)
QUIT
IF $DATA(DIRUT)
KILL DIRUT
GOTO CTSOR
CTEDT DO EDT^PXRMGECP
if $DATA(DIROUT)
QUIT
IF $DATA(DIRUT)
KILL DIRUT
GOTO CTBDT
CTFOR DO FOR^PXRMGECP
if $DATA(DIROUT)
QUIT
IF $DATA(DIRUT)
KILL DIRUT
GOTO CTEDT
CTIOO DO CTIO
if $DATA(DIROUT)
QUIT
+1 QUIT
+2 ;
SOR ;======Sort Type
+1 ;--Return SOR as Type of report
+2 SET DIR("A")="Select Sort Type or ^ to exit"
+3 IF $DATA(^DISV(DUZ,"PXRMGEC","SOR"))
SET DIR("B")=$GET(^DISV(DUZ,"PXRMGEC","SOR"))
+4 SET DIR(0)="S^PA:Patient;PR:Provider;L:Location;D:Date"
+5 DO ^DIR
+6 KILL DIR("A"),DIR("B"),DIR(0)
+7 if $DATA(DIRUT)!($DATA(DIROUT))
QUIT
+8 SET ^DISV(DUZ,"PXRMGEC","SOR")=X
+9 SET SOR=Y
+10 QUIT
+11 ;
CTIO ;=====Select IO device
+1 NEW %ZIS
+2 SET %ZIS="QM"
DO ^%ZIS
+3 IF POP
QUIT
+4 ;=====Call Report
+5 IF SOR="PA"
Begin DoDot:1
+6 IF $DATA(IO("Q"))
Begin DoDot:2
+7 SET ZTRTN="CTP^PXRMGECT"
+8 SET ZTDESC="GEC COUNT TOTALS REPORTS"
+9 SET ZTSAVE("*")=""
+10 DO ^%ZTLOAD
End DoDot:2
+11 IF '$TEST
DO CTP^PXRMGECS
End DoDot:1
+12 IF SOR="PR"
Begin DoDot:1
+13 IF $DATA(IO("Q"))
Begin DoDot:2
+14 SET ZTRTN="CTDR^PXRMGECT"
+15 SET ZTDESC="GEC COUNT TOTALS REPORTS"
+16 SET ZTSAVE("*")=""
+17 DO ^%ZTLOAD
End DoDot:2
+18 IF '$TEST
DO CTDR^PXRMGECS
End DoDot:1
+19 IF SOR="L"
Begin DoDot:1
+20 IF $DATA(IO("Q"))
Begin DoDot:2
+21 SET ZTRTN="CTL^PXRMGECT"
+22 SET ZTDESC="GEC COUNT TOTALS REPORTS"
+23 SET ZTSAVE("*")=""
+24 DO ^%ZTLOAD
End DoDot:2
+25 IF '$TEST
DO CTL^PXRMGECS
End DoDot:1
+26 IF SOR="D"
Begin DoDot:1
+27 IF $DATA(IO("Q"))
Begin DoDot:2
+28 SET ZTRTN="CTD^PXRMGECT"
+29 SET ZTDESC="GEC COUNT TOTALS REPORTS"
+30 SET ZTSAVE("*")=""
+31 DO ^%ZTLOAD
End DoDot:2
+32 IF '$TEST
DO CTD^PXRMGECS
End DoDot:1
+33 DO ^%ZISC
+34 if '$DATA(DIRUT)&('$DATA(DUOUT))&('$DATA(DIROUT))
SET DIR(0)="E"
DO ^DIR
KILL DIR(0),Y
+35 QUIT
+36 ;
