- PXRMGECP ;SLC/JVS -GEC-Prompts ;7/14/05 10:43
- ;;2.0;CLINICAL REMINDERS;**2,4**;Feb 04, 2005;Build 21
- Q
- EN ;Entry Point
- ;^DISV( = DBIA #510
- N POP,DIROUT,DIRUT,DUOUT,LOCNP,MENU,PROV,Y
- N DETAIL,FORMAT,INC
- ;D INIT^PXRMGECW
- S X="IOUON;IOUOFF;IORVOFF;IORVON" D ENDR^%ZISS
- W IOUOFF,IORVOFF
- W @IOF
- W !,"All Reports will print on 80 Columns"
- K DIR
- S DIR("A")="Select Option or ^ to Exit"
- I $D(^DISV(DUZ,"PXRMGEC","EN")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","EN"))
- S DIR(0)="S^1:Category;2:Patient;3:Provider by Patient;4:Referral Date;5:Location;6:Referral Count Totals;7:Category-Referred Service;8:Summary (Score);9:'Home Help' Eligibility;10:Restore or Merge Referrals"
- D ^DIR
- K DIR("A"),DIR("B"),DIR(0)
- Q:$D(DIRUT)!($D(DIROUT))
- ;DBIA #510
- S MENU=Y,^DISV(DUZ,"PXRMGEC","EN")=MENU
- I MENU=1 D CAT
- I MENU=2 D PATIENT
- I MENU=3 D PRO
- I MENU=4 D DR
- I MENU=5 D LOCDIR^PXRMGECO
- I MENU=6 D CT^PXRMGECO
- I MENU=7 D RS^PXRMGECO
- I MENU=8 D SUM^PXRMGECO
- I MENU=9 D HOME^PXRMG2R2
- I MENU=10 D EN^PXRMGECJ
- D KILL^%ZISS
- Q
- ;==========================================================
- ;
- CAT ;#1 Start List and array of GEC Categories
- ;
- N CAT,CATNA,CNT,STAY,NUM,CATIEN,CATARY,BDT,EDT,CATDA,SYN
- W @IOF
- W "GEC Referral Categories"
- S CNT=0
- S SYN="" F S SYN=$O(^AUTTHF("D",SYN)) Q:SYN="" D
- .I $E(SYN,1,3)="GEC",$E(SYN,5)="C" D
- ..S CAT=0 F S CAT=$O(^AUTTHF("D",SYN,CAT)) Q:CAT="" D
- ...Q:$P($G(^AUTTHF(CAT,0)),"^",11)=1
- ...S CATNA=$P($G(^AUTTHF(CAT,0)),"^",1)
- ...S CATNA=$P(CATNA," ",3,7)
- ...S CATARY(CATNA,CAT)=""
- 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
- SC ;=====Select Categories
- 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","SC")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","SC"))
- 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","SC")=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
- CATBDT D BDT Q:$D(DIROUT)!$D(DIRUT)
- CATEDT D EDT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G CATBDT
- CATPAT D PAT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G CATEDT
- CATFOR D FOR Q:$D(DIROUT) I $D(DIRUT) K DIRUT G CATPAT
- CATIOO D CATIO Q:$D(DIROUT)
- Q
- BDT ;=====Select Beginning Date
- ;--Return BDT as DATE
- W !
- S DIR("A",1)="Select a Beginning Historical Date."
- S DIR("A")="BEGINNING date or ^ to exit"
- I $D(^DISV(DUZ,"PXRMGEC","BDT")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","BDT"))
- S DIR(0)="D^2880101:"_DT_":EX"
- D ^DIR
- K DIR("A"),DIR("B"),DIR(0)
- Q:$D(DIROUT)!($D(DIRUT))
- S ^DISV(DUZ,"PXRMGEC","BDT")=X
- S BDT=Y
- Q
- ;
- EDT ;=====Select Ending Date
- ;--Return EDT as DATE
- W !
- S DIR("A",1)="Select Ending Date."
- S DIR("A")="ENDING date or ^ to exit"
- I $D(^DISV(DUZ,"PXRMGEC","EDT")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","EDT"))
- S DIR(0)="D^"_BDT_":"_DT_":EX"
- D ^DIR
- K DIR("A"),DIR("B"),DIR(0)
- Q:$D(DIROUT)!($D(DIRUT))
- S ^DISV(DUZ,"PXRMGEC","EDT")=X
- S EDT=Y
- Q
- ;=====Select Patients
- PAT ;--Return DFNONLY as Patient DFN
- W @IOF
- K DIR,DIR("A")
- K DFNONLY
- S DIR("A")="Select Patients or ^ to exit"
- I $D(^DISV(DUZ,"PXRMGEC","PAT")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","PAT"))
- S DIR(0)="S^A:All Patients;M:Multiple Patients"
- D ^DIR
- K DIR("A"),DIR("B"),DIR(0)
- Q:$D(DIROUT)!($D(DIRUT))
- S ^DISV(DUZ,"PXRMGEC","PAT")=X
- I Y="A" S DFNONLY=0
- I Y="M" D PATLU
- Q
- ;
- FOR ;=====Formatted or Delimited Report
- ;--Return FORMAT equal to Y
- S DIR("A")="Select Report Format or ^ to exit"
- I $D(^DISV(DUZ,"PXRMGEC","FOR")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","FOR"))
- S DIR(0)="S^F:Formatted;D:Delimited"
- D ^DIR
- K DIR("A"),DIR("B"),DIR(0)
- Q:$D(DIRUT)!($D(DIROUT))
- S ^DISV(DUZ,"PXRMGEC","FOR")=X
- S FORMAT=Y
- Q
- ;
- CATIO ;=====Select IO device
- Q:'$D(BDT)!('$D(EDT))!('$D(DFNONLY))!'$D(FORMAT)
- N %ZIS
- S %ZIS="QM" D ^%ZIS
- I POP Q
- I $D(IO("Q")) D
- .S ZTRTN="HFCD^PXRMGECQ"
- .S ZTDESC="Gec Report Printing"
- .S ZTSAVE("*")=""
- .D ^%ZTLOAD K IO("Q") Q
- ;=====Call Report
- E D HFCD^PXRMGECR
- D HOME^%ZIS
- D ^%ZISC
- S:'$D(DIRUT)&('$D(DUOUT))&('$D(DIROUT)) DIR(0)="E" D ^DIR K DIR(0),Y
- Q
- ;
- ;================SUB ROUTINES==============================
- PROV ;Select Provider
- W @IOF
- N DIC,Y
- S PROV=0
- K PROVARY
- S DIC="^VA(200,"
- S DIC(0)="QAMEZ"
- PROVR D ^DIC
- I Y=-1 K DIC,DIC(0),Y Q
- I +Y>0 S PROVARY(+Y)=""
- S PROV=+Y
- G PROVR
- Q
- ;
- PATLU ;Patient Look up
- N Y,DIC
- S DFNONLY=0
- K DFNARY
- S DIC="^DPT("
- S DIC(0)="QAMEZ"
- PATLUR D ^DIC
- I Y=-1 K DIC,DIC(0),Y Q
- I +Y>0 S DFNONLY=+Y,DFNARY(+Y)=""
- G PATLUR
- Q
- ;
- ;================================================================
- PRO ; #3 Start of Provider by Patient Report
- N BDT,EDT,DFNONLY
- W @IOF
- K DIR
- I $D(^DISV(DUZ,"PXRMGEC","PRO")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","PRO"))
- S DIR(0)="S^A:All Providers;M:Multiple Providers"
- D ^DIR
- K DIR("A"),DIR("B"),DIR(0)
- Q:$D(DIRUT)!($D(DUOUT))
- Q:$D(DIROUT)
- S ^DISV(DUZ,"PXRMGEC","PRO")=X
- I Y="A" S PROV=0
- I Y="M" D PROV Q:'$D(PROVARY)
- Q:$D(DIRUT)!($D(DIROUT))
- PROBDT D BDT Q:$D(DIRUT)!($D(DIRUT))
- PROEDT D EDT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G PROBDT
- PROFOR D FOR Q:$D(DIROUT) I $D(DIRUT) K DIRUT G PROEDT
- PROIOO D PROIO Q:$D(DIROUT)
- Q
- ;
- PROIO ;=====Select IO device
- N %ZIS
- S %ZIS="QM" D ^%ZIS
- I POP Q
- I $D(IO("Q")) D
- .S ZTRTN="DFN2^PXRMGECQ"
- .S ZTDESC="GEC PROVIDER REPORT"
- .S ZTSAVE("*")=""
- .D ^%ZTLOAD K IO("Q") Q
- ;=====Call Report
- E D DFN2^PXRMGECS
- D HOME^%ZIS
- D ^%ZISC
- S:'$D(DIRUT)&('$D(DUOUT))&('$D(DIROUT)) DIR(0)="E" D ^DIR K DIR(0),Y
- Q
- ;=================================================================
- DR ; #4 Referral Date
- ;
- DRPAT D PAT Q:$D(DIROUT)!($D(DIRUT))
- DRBDT D BDT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G DRPAT
- DREDT D EDT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G DRBDT
- DRALL D ALL Q:$D(DIROUT) I $D(DIRUT) K DIRUT G DREDT
- DRFOR D FOR Q:$D(DIROUT) I $D(DIRUT) K DIRUT G DRALL
- DRIOO D DRIO Q:$D(DIROUT)
- Q
- ;
- ALL ;=====Select All Referrals or
- ;--Return INC equal to Y
- I $D(^DISV(DUZ,"PXRMGEC","ALL")) S DIR("B")=$G(^DISV(DUZ,"PXRMGEC","ALL"))
- S DIR(0)="S^I:Incomplete Referrals Only;C:Complete Referrals Only;B:Both Complete and Incomplete"
- D ^DIR
- K DIR("A"),DIR("B"),DIR(0)
- Q:$D(DIRUT)!($D(DUOUT))
- S ^DISV(DUZ,"PXRMGEC","ALL")=X
- I Y="I" S INC=0
- I Y="C" S INC=1
- I Y="B" S INC=2
- Q
- ;
- DRIO ;=====Select IO device
- N %ZIS
- S %ZIS="QM" D ^%ZIS
- I POP Q
- I $D(IO("Q")) D
- .S ZTRTN="DR^PXRMGECQ"
- .S ZTDESC="GEC REPORT"
- .S ZTSAVE("*")=""
- .D ^%ZTLOAD K IO("Q") Q
- ;=====Call Report
- E D DR^PXRMGECR
- D HOME^%ZIS
- D ^%ZISC
- S:'$D(DIRUT)&('$D(DUOUT))&('$D(DIROUT)) DIR(0)="E" D ^DIR K DIR(0),Y
- Q
- ;
- ;==================================================================
- PATIENT ; #2 Start of Patient Report
- ;
- PATPAT D PAT Q:$D(DIROUT)!($D(DIRUT))
- PATBDT D BDT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G PATPAT
- PATEDT D EDT Q:$D(DIROUT) I $D(DIRUT) K DIRUT G PATBDT
- PATFOR D FOR Q:$D(DIROUT) I $D(DIRUT) K DIRUT G PATEDT
- PATIOO D PATIO Q:$D(DIROUT)
- Q
- ;
- PATIO ;=====Select IO device for Patient Report
- N %ZIS
- S %ZIS="QM" D ^%ZIS
- I POP Q
- I $D(IO("Q")) D
- .S ZTRTN="HS1^PXRMGECQ"
- .S ZTDESC="GEC PATIENT REPORT"
- .S ZTSAVE("*")=""
- .S ZTSAVE("FORMAT")=""
- .S ZTSAVE("EDT")=""
- .S ZTSAVE("BDT")=""
- .S ZTSAVE("DFNONLY")=""
- .I $D(DFNARY) S ZTSAVE("DFNARY(")=""
- .D ^%ZTLOAD K IO("Q") Q
- ;=====Call Report
- E D HS1^PXRMGECR
- D HOME^%ZIS
- 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[HPXRMGECP 8059 printed Feb 18, 2025@23:12:10 Page 2
- PXRMGECP ;SLC/JVS -GEC-Prompts ;7/14/05 10:43
- +1 ;;2.0;CLINICAL REMINDERS;**2,4**;Feb 04, 2005;Build 21
- +2 QUIT
- EN ;Entry Point
- +1 ;^DISV( = DBIA #510
- +2 NEW POP,DIROUT,DIRUT,DUOUT,LOCNP,MENU,PROV,Y
- +3 NEW DETAIL,FORMAT,INC
- +4 ;D INIT^PXRMGECW
- +5 SET X="IOUON;IOUOFF;IORVOFF;IORVON"
- DO ENDR^%ZISS
- +6 WRITE IOUOFF,IORVOFF
- +7 WRITE @IOF
- +8 WRITE !,"All Reports will print on 80 Columns"
- +9 KILL DIR
- +10 SET DIR("A")="Select Option or ^ to Exit"
- +11 IF $DATA(^DISV(DUZ,"PXRMGEC","EN"))
- SET DIR("B")=$GET(^DISV(DUZ,"PXRMGEC","EN"))
- +12 SET DIR(0)="S^1:Category;2:Patient;3:Provider by Patient;4:Referral Date;5:Location;6:Referral Count Totals;7:Category-Referred Service;8:Summary (Score);9:'Home Help' Eligibility;10:Restore or Merge Referrals"
- +13 DO ^DIR
- +14 KILL DIR("A"),DIR("B"),DIR(0)
- +15 if $DATA(DIRUT)!($DATA(DIROUT))
- QUIT
- +16 ;DBIA #510
- +17 SET MENU=Y
- SET ^DISV(DUZ,"PXRMGEC","EN")=MENU
- +18 IF MENU=1
- DO CAT
- +19 IF MENU=2
- DO PATIENT
- +20 IF MENU=3
- DO PRO
- +21 IF MENU=4
- DO DR
- +22 IF MENU=5
- DO LOCDIR^PXRMGECO
- +23 IF MENU=6
- DO CT^PXRMGECO
- +24 IF MENU=7
- DO RS^PXRMGECO
- +25 IF MENU=8
- DO SUM^PXRMGECO
- +26 IF MENU=9
- DO HOME^PXRMG2R2
- +27 IF MENU=10
- DO EN^PXRMGECJ
- +28 DO KILL^%ZISS
- +29 QUIT
- +30 ;==========================================================
- +31 ;
- CAT ;#1 Start List and array of GEC Categories
- +1 ;
- +2 NEW CAT,CATNA,CNT,STAY,NUM,CATIEN,CATARY,BDT,EDT,CATDA,SYN
- +3 WRITE @IOF
- +4 WRITE "GEC Referral Categories"
- +5 SET CNT=0
- +6 SET SYN=""
- FOR
- SET SYN=$ORDER(^AUTTHF("D",SYN))
- if SYN=""
- QUIT
- Begin DoDot:1
- +7 IF $EXTRACT(SYN,1,3)="GEC"
- IF $EXTRACT(SYN,5)="C"
- Begin DoDot:2
- +8 SET CAT=0
- FOR
- SET CAT=$ORDER(^AUTTHF("D",SYN,CAT))
- if CAT=""
- QUIT
- Begin DoDot:3
- +9 if $PIECE($GET(^AUTTHF(CAT,0)),"^",11)=1
- QUIT
- +10 SET CATNA=$PIECE($GET(^AUTTHF(CAT,0)),"^",1)
- +11 SET CATNA=$PIECE(CATNA," ",3,7)
- +12 SET CATARY(CATNA,CAT)=""
- End DoDot:3
- 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
- SC ;=====Select Categories
- +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","SC"))
- SET DIR("B")=$GET(^DISV(DUZ,"PXRMGEC","SC"))
- +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","SC")=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
- CATBDT DO BDT
- if $DATA(DIROUT)!$DATA(DIRUT)
- QUIT
- CATEDT DO EDT
- if $DATA(DIROUT)
- QUIT
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO CATBDT
- CATPAT DO PAT
- if $DATA(DIROUT)
- QUIT
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO CATEDT
- CATFOR DO FOR
- if $DATA(DIROUT)
- QUIT
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO CATPAT
- CATIOO DO CATIO
- if $DATA(DIROUT)
- QUIT
- +1 QUIT
- BDT ;=====Select Beginning Date
- +1 ;--Return BDT as DATE
- +2 WRITE !
- +3 SET DIR("A",1)="Select a Beginning Historical Date."
- +4 SET DIR("A")="BEGINNING date or ^ to exit"
- +5 IF $DATA(^DISV(DUZ,"PXRMGEC","BDT"))
- SET DIR("B")=$GET(^DISV(DUZ,"PXRMGEC","BDT"))
- +6 SET DIR(0)="D^2880101:"_DT_":EX"
- +7 DO ^DIR
- +8 KILL DIR("A"),DIR("B"),DIR(0)
- +9 if $DATA(DIROUT)!($DATA(DIRUT))
- QUIT
- +10 SET ^DISV(DUZ,"PXRMGEC","BDT")=X
- +11 SET BDT=Y
- +12 QUIT
- +13 ;
- EDT ;=====Select Ending Date
- +1 ;--Return EDT as DATE
- +2 WRITE !
- +3 SET DIR("A",1)="Select Ending Date."
- +4 SET DIR("A")="ENDING date or ^ to exit"
- +5 IF $DATA(^DISV(DUZ,"PXRMGEC","EDT"))
- SET DIR("B")=$GET(^DISV(DUZ,"PXRMGEC","EDT"))
- +6 SET DIR(0)="D^"_BDT_":"_DT_":EX"
- +7 DO ^DIR
- +8 KILL DIR("A"),DIR("B"),DIR(0)
- +9 if $DATA(DIROUT)!($DATA(DIRUT))
- QUIT
- +10 SET ^DISV(DUZ,"PXRMGEC","EDT")=X
- +11 SET EDT=Y
- +12 QUIT
- +13 ;=====Select Patients
- PAT ;--Return DFNONLY as Patient DFN
- +1 WRITE @IOF
- +2 KILL DIR,DIR("A")
- +3 KILL DFNONLY
- +4 SET DIR("A")="Select Patients or ^ to exit"
- +5 IF $DATA(^DISV(DUZ,"PXRMGEC","PAT"))
- SET DIR("B")=$GET(^DISV(DUZ,"PXRMGEC","PAT"))
- +6 SET DIR(0)="S^A:All Patients;M:Multiple Patients"
- +7 DO ^DIR
- +8 KILL DIR("A"),DIR("B"),DIR(0)
- +9 if $DATA(DIROUT)!($DATA(DIRUT))
- QUIT
- +10 SET ^DISV(DUZ,"PXRMGEC","PAT")=X
- +11 IF Y="A"
- SET DFNONLY=0
- +12 IF Y="M"
- DO PATLU
- +13 QUIT
- +14 ;
- FOR ;=====Formatted or Delimited Report
- +1 ;--Return FORMAT equal to Y
- +2 SET DIR("A")="Select Report Format or ^ to exit"
- +3 IF $DATA(^DISV(DUZ,"PXRMGEC","FOR"))
- SET DIR("B")=$GET(^DISV(DUZ,"PXRMGEC","FOR"))
- +4 SET DIR(0)="S^F:Formatted;D:Delimited"
- +5 DO ^DIR
- +6 KILL DIR("A"),DIR("B"),DIR(0)
- +7 if $DATA(DIRUT)!($DATA(DIROUT))
- QUIT
- +8 SET ^DISV(DUZ,"PXRMGEC","FOR")=X
- +9 SET FORMAT=Y
- +10 QUIT
- +11 ;
- CATIO ;=====Select IO device
- +1 if '$DATA(BDT)!('$DATA(EDT))!('$DATA(DFNONLY))!'$DATA(FORMAT)
- QUIT
- +2 NEW %ZIS
- +3 SET %ZIS="QM"
- DO ^%ZIS
- +4 IF POP
- QUIT
- +5 IF $DATA(IO("Q"))
- Begin DoDot:1
- +6 SET ZTRTN="HFCD^PXRMGECQ"
- +7 SET ZTDESC="Gec Report Printing"
- +8 SET ZTSAVE("*")=""
- +9 DO ^%ZTLOAD
- KILL IO("Q")
- QUIT
- End DoDot:1
- +10 ;=====Call Report
- +11 IF '$TEST
- DO HFCD^PXRMGECR
- +12 DO HOME^%ZIS
- +13 DO ^%ZISC
- +14 if '$DATA(DIRUT)&('$DATA(DUOUT))&('$DATA(DIROUT))
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR(0),Y
- +15 QUIT
- +16 ;
- +17 ;================SUB ROUTINES==============================
- PROV ;Select Provider
- +1 WRITE @IOF
- +2 NEW DIC,Y
- +3 SET PROV=0
- +4 KILL PROVARY
- +5 SET DIC="^VA(200,"
- +6 SET DIC(0)="QAMEZ"
- PROVR DO ^DIC
- +1 IF Y=-1
- KILL DIC,DIC(0),Y
- QUIT
- +2 IF +Y>0
- SET PROVARY(+Y)=""
- +3 SET PROV=+Y
- +4 GOTO PROVR
- +5 QUIT
- +6 ;
- PATLU ;Patient Look up
- +1 NEW Y,DIC
- +2 SET DFNONLY=0
- +3 KILL DFNARY
- +4 SET DIC="^DPT("
- +5 SET DIC(0)="QAMEZ"
- PATLUR DO ^DIC
- +1 IF Y=-1
- KILL DIC,DIC(0),Y
- QUIT
- +2 IF +Y>0
- SET DFNONLY=+Y
- SET DFNARY(+Y)=""
- +3 GOTO PATLUR
- +4 QUIT
- +5 ;
- +6 ;================================================================
- PRO ; #3 Start of Provider by Patient Report
- +1 NEW BDT,EDT,DFNONLY
- +2 WRITE @IOF
- +3 KILL DIR
- +4 IF $DATA(^DISV(DUZ,"PXRMGEC","PRO"))
- SET DIR("B")=$GET(^DISV(DUZ,"PXRMGEC","PRO"))
- +5 SET DIR(0)="S^A:All Providers;M:Multiple Providers"
- +6 DO ^DIR
- +7 KILL DIR("A"),DIR("B"),DIR(0)
- +8 if $DATA(DIRUT)!($DATA(DUOUT))
- QUIT
- +9 if $DATA(DIROUT)
- QUIT
- +10 SET ^DISV(DUZ,"PXRMGEC","PRO")=X
- +11 IF Y="A"
- SET PROV=0
- +12 IF Y="M"
- DO PROV
- if '$DATA(PROVARY)
- QUIT
- +13 if $DATA(DIRUT)!($DATA(DIROUT))
- QUIT
- PROBDT DO BDT
- if $DATA(DIRUT)!($DATA(DIRUT))
- QUIT
- PROEDT DO EDT
- if $DATA(DIROUT)
- QUIT
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO PROBDT
- PROFOR DO FOR
- if $DATA(DIROUT)
- QUIT
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO PROEDT
- PROIOO DO PROIO
- if $DATA(DIROUT)
- QUIT
- +1 QUIT
- +2 ;
- PROIO ;=====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="DFN2^PXRMGECQ"
- +6 SET ZTDESC="GEC PROVIDER REPORT"
- +7 SET ZTSAVE("*")=""
- +8 DO ^%ZTLOAD
- KILL IO("Q")
- QUIT
- End DoDot:1
- +9 ;=====Call Report
- +10 IF '$TEST
- DO DFN2^PXRMGECS
- +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 ;=================================================================
- DR ; #4 Referral Date
- +1 ;
- DRPAT DO PAT
- if $DATA(DIROUT)!($DATA(DIRUT))
- QUIT
- DRBDT DO BDT
- if $DATA(DIROUT)
- QUIT
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO DRPAT
- DREDT DO EDT
- if $DATA(DIROUT)
- QUIT
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO DRBDT
- DRALL DO ALL
- if $DATA(DIROUT)
- QUIT
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO DREDT
- DRFOR DO FOR
- if $DATA(DIROUT)
- QUIT
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO DRALL
- DRIOO DO DRIO
- if $DATA(DIROUT)
- QUIT
- +1 QUIT
- +2 ;
- ALL ;=====Select All Referrals or
- +1 ;--Return INC equal to Y
- +2 IF $DATA(^DISV(DUZ,"PXRMGEC","ALL"))
- SET DIR("B")=$GET(^DISV(DUZ,"PXRMGEC","ALL"))
- +3 SET DIR(0)="S^I:Incomplete Referrals Only;C:Complete Referrals Only;B:Both Complete and Incomplete"
- +4 DO ^DIR
- +5 KILL DIR("A"),DIR("B"),DIR(0)
- +6 if $DATA(DIRUT)!($DATA(DUOUT))
- QUIT
- +7 SET ^DISV(DUZ,"PXRMGEC","ALL")=X
- +8 IF Y="I"
- SET INC=0
- +9 IF Y="C"
- SET INC=1
- +10 IF Y="B"
- SET INC=2
- +11 QUIT
- +12 ;
- DRIO ;=====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="DR^PXRMGECQ"
- +6 SET ZTDESC="GEC REPORT"
- +7 SET ZTSAVE("*")=""
- +8 DO ^%ZTLOAD
- KILL IO("Q")
- QUIT
- End DoDot:1
- +9 ;=====Call Report
- +10 IF '$TEST
- DO DR^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 ;
- +16 ;==================================================================
- PATIENT ; #2 Start of Patient Report
- +1 ;
- PATPAT DO PAT
- if $DATA(DIROUT)!($DATA(DIRUT))
- QUIT
- PATBDT DO BDT
- if $DATA(DIROUT)
- QUIT
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO PATPAT
- PATEDT DO EDT
- if $DATA(DIROUT)
- QUIT
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO PATBDT
- PATFOR DO FOR
- if $DATA(DIROUT)
- QUIT
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO PATEDT
- PATIOO DO PATIO
- if $DATA(DIROUT)
- QUIT
- +1 QUIT
- +2 ;
- PATIO ;=====Select IO device for Patient Report
- +1 NEW %ZIS
- +2 SET %ZIS="QM"
- DO ^%ZIS
- +3 IF POP
- QUIT
- +4 IF $DATA(IO("Q"))
- Begin DoDot:1
- +5 SET ZTRTN="HS1^PXRMGECQ"
- +6 SET ZTDESC="GEC PATIENT REPORT"
- +7 SET ZTSAVE("*")=""
- +8 SET ZTSAVE("FORMAT")=""
- +9 SET ZTSAVE("EDT")=""
- +10 SET ZTSAVE("BDT")=""
- +11 SET ZTSAVE("DFNONLY")=""
- +12 IF $DATA(DFNARY)
- SET ZTSAVE("DFNARY(")=""
- +13 DO ^%ZTLOAD
- KILL IO("Q")
- QUIT
- End DoDot:1
- +14 ;=====Call Report
- +15 IF '$TEST
- DO HS1^PXRMGECR
- +16 DO HOME^%ZIS
- +17 DO ^%ZISC
- +18 if '$DATA(DIRUT)&('$DATA(DUOUT))&('$DATA(DIROUT))
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR(0),Y
- +19 QUIT
- +20 ;=========================================================