APCLDMAP ; IHS/CMI/LAB - print hs for dm patients with appts ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;
;this routine will go through the Diabetes Register
;and then see if the patient has an appt, if so print health sum
;
EP ;EP - called from option interactive
D EOJ
W:$D(IOF) @IOF
W !!,"This option will print a list of all patients on a register"
W !,"e.g. Diabetes Register) who have an appointment in a date range"
W !,"in any clinic or in a selected set of clinics.",!!
W !!,"You will be asked to enter the name of the register, the date range of the"
W !,"appointments and the clinic names if selecting a set of clinics.",!
REGISTER ;get register name
S APCLREG=""
W ! S DIC="^ACM(41.1,",DIC(0)="AEMQ",DIC("A")="Enter the Name of the Register: " D ^DIC
I Y=-1 S APCLREG="" W !,"No Register Selected." G EOJ
S APCLREG=+Y
DATES K APCLED,APCLBD
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Appointment Date"
D ^DIR G:Y<1 REGISTER S APCLBD=Y
K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter Ending Appointment Date"
D ^DIR G:Y<1 REGISTER S APCLED=Y
;
I APCLED<APCLBD D G DATES
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
S APCLSD=$$FMADD^XLFDT(APCLBD,-1)_".9999"
;
CLIN ;
S APCLCLN=""
S DIR(0)="S^A:ANY Clinic;S:One or more selected Clinics",DIR("A")="Include patients with Appointments to",DIR("B")="A" KILL DA D ^DIR KILL DIR
G:$D(DIRUT) DATES
S APCLCLN=Y
I APCLCLN="A" K APCLCLN G ZIS
;get which clinics
K APCLCLN
CLIN1 ;
W ! S DIC="^SC(",DIC(0)="AEMZQ",DIC("A")="Select CLINIC: "
S DIC("S")="I $P(^(0),U,3)=""C""" D ^DIC K DIC
I Y=-1,'$D(APCLCLN) G CLIN
I X="^" G CLIN
I Y="",$D(APCLCLN) G ZIS
I Y=-1,$D(APCLCLN) G ZIS
I X="",'$D(APCLCLN) G CLIN
S APCLCLN(+Y)=""
G CLIN1
ZIS ;
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G CLIN
S XBRP="PRINT^APCLDMAP",XBRC="PROC^APCLDMAP",XBRX="EOJ^APCLDMAP",XBNS="APCL"
D ^XBDBQUE
Q
EOJ ;
D ^XBFMK
K DIC,DIR
D EN^XBVK("APCL")
Q
;
TEST ;
D BDMG(1,3040101,3041231,13)
Q
BDMG(APCLREG,APCLBD,APCLED,APCLCLN) ;EP - GUI DMS Entry Point
;cmi/anch/maw added 10/19/2004
S APCLSD=$$FMADD^XLFDT(APCLBD,-1)_".9999"
S APCLGUI=1
N APCLOPT,APCLNOW,APCLIEN ;maw
S APCLOPT="List Patients on a Register w/an Appointment"
D NOW^%DTC
S APCLNOW=$G(%)
K DD,D0,DIC
S X=DUZ_$$NOW^XLFDT
S DIC("DR")=".02////"_DUZ_";.03////"_APCLNOW_";.06///"_$G(APCLOPT)_";.07////R"
S DIC="^APCLGUIR(",DIC(0)="L",DIADD=1,DLAYGO=9001004.4
D FILE^DICN
K DIADD,DLAYGO,DIC,DA
I Y=-1 S APCLIEN=-1 Q
S APCLIEN=+Y
S BDMGIEN=APCLIEN ;cmi/maw added
D ^XBFMK
K ZTSAVE S ZTSAVE("*")=""
;D GUIEP for interactive testing
S ZTIO="",ZTDTH=$$NOW^XLFDT,ZTRTN="GUIEP^APCLDMAP",ZTDESC="GUI DM REG APPT" D ^%ZTLOAD
D EOJ
Q
GUIEP ;EP
D PROC
K ^TMP($J,"APCLDMAP")
S IOM=80
D GUIR^XBLM("PRINT^APCLDMAP","^TMP($J,""APCLDMAP"",")
S X=0,C=0 F S X=$O(^TMP($J,"APCLDMAP",X)) Q:X'=+X D
.S APCLDATA=^TMP($J,"APCLDMAP",X)
.I APCLDATA="ZZZZZZZ" S APCLDATA=$C(12)
.S ^APCLGUIR(APCLIEN,11,X,0)=APCLDATA,C=C+1
S ^APCLGUIR(APCLIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
S DA=APCLIEN,DIK="^APCLGUIR(" D IX1^DIK
D ENDLOG
K ^TMP($J,"APCLDMAP")
S ZTREQ="@"
Q
;
ENDLOG ;-- write the end of the log
D NOW^%DTC
S APCLNOW=$G(%)
S DIE="^APCLGUIR(",DA=APCLIEN,DR=".04////"_APCLNOW_";.07////C"
D ^DIE
K DIE,DR,DA
Q
;
PROC ;
S APCLJ=$J,APCLH=$H
S ^XTMP("APCLDMAP",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"REGISTER PTS WITH APPT"
S APCLDMX=0 F S APCLDMX=$O(^ACM(41,"B",APCLREG,APCLDMX)) Q:APCLDMX'=+APCLDMX D
.;check to see if patient has an appt
.S DFN=$P(^ACM(41,APCLDMX,0),U,2)
.Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
.S APCLDMY=APCLSD F S APCLDMY=$O(^DPT(DFN,"S",APCLDMY)) Q:APCLDMY=""!($P(APCLDMY,".")>APCLED) D
..I $P(^DPT(DFN,"S",APCLDMY,0),U,2)["C" Q ;cancelled
..I $D(APCLCLN) S X=$P(^DPT(DFN,"S",APCLDMY,0),U) I '$D(APCLCLN(X)) Q ;not a clinic of interest
..S ^XTMP("APCLDMAP",APCLJ,APCLH,"APPTS",DFN,APCLDMY,$P(^DPT(DFN,"S",APCLDMY,0),U))=""
..Q
.Q
Q
DONE ;
I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report. PRESS ENTER" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
W:$D(IOF) @IOF
K APCLTS,APCLS,APCLM,APCLET
K ^XTMP("APCLDMAP",APCLJ,APCLH),APCLJ,APCLH
Q
;
PRINT ;EP - called from xbdbque
S APCLIOSL=$S($G(APCLGUI):55,1:IOSL)
K APCLQ S APCLPG=0 D HEADER
I '$D(^XTMP("APCLDMAP",APCLJ,APCLH)) W !!,"NO DATA TO REPORT",! G DONE
S DFN=0 F S DFN=$O(^XTMP("APCLDMAP",APCLJ,APCLH,"APPTS",DFN)) Q:DFN'=+DFN!($D(APCLQ)) D
.S APCLD=0 F S APCLD=$O(^XTMP("APCLDMAP",APCLJ,APCLH,"APPTS",DFN,APCLD)) Q:APCLD'=+APCLD!($D(APCLQ)) D
..S APCLC=0 F S APCLC=$O(^XTMP("APCLDMAP",APCLJ,APCLH,"APPTS",DFN,APCLD,APCLC)) Q:APCLC'=+APCLC!($D(APCLQ)) D
...I $Y>(APCLIOSL-4) D HEADER Q:$D(APCLQ)
...W !,$$HRN^AUPNPAT(DFN,DUZ(2)),?7,$E($P(^DPT(DFN,0),U),1,25),?38,$E($P(^SC(APCLC,0),U),1,20),?59,$$FMTE^XLFDT($P(APCLD,".")),?72,$P($$FMTE^XLFDT(APCLD,"2P")," ",2)
D DONE
Q
G:'APCLPG HEADER1
K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQ="" Q
W:$D(IOF) @IOF S APCLPG=APCLPG+1
I $G(APCLGUI),APCLPG'=1 W !,"ZZZZZZZ"
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCLPG,!
W !,$$CTR("PATIENTS ON THE "_$P(^ACM(41.1,APCLREG,0),U)_" REGISTER WITH AN APPOINTMENT",80),!
S X="Appointment Dates: "_$$FMTE^XLFDT(APCLBD)_" to "_$$FMTE^XLFDT(APCLED) W $$CTR(X,80),!
W $$CTR("CLINICS: "_$S($D(APCLCLN):"USER SELECTED",1:"ANY"),80),!
W !,"HRN",?7,"PATIENT NAME",?38,"CLINIC NAME",?59,"DATE",?72,"TIME"
W !,$TR($J("",80)," ","-")
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR("A")="End of report. Press Enter",DIR(0)="E" D ^DIR
Q
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
POST ;
NEW X
S X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM REG APPT CLN","APCL")
I 'X W "Attempt to new appt list of reg pats failed.." H 3
Q
APCLDMAP ; IHS/CMI/LAB - print hs for dm patients with appts ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;
+4 ;this routine will go through the Diabetes Register
+5 ;and then see if the patient has an appt, if so print health sum
+6 ;
EP ;EP - called from option interactive
+1 DO EOJ
+2 IF $DATA(IOF)
WRITE @IOF
+3 WRITE !!,"This option will print a list of all patients on a register"
+4 WRITE !,"e.g. Diabetes Register) who have an appointment in a date range"
+5 WRITE !,"in any clinic or in a selected set of clinics.",!!
+6 WRITE !!,"You will be asked to enter the name of the register, the date range of the"
+7 WRITE !,"appointments and the clinic names if selecting a set of clinics.",!
REGISTER ;get register name
+1 SET APCLREG=""
+2 WRITE !
SET DIC="^ACM(41.1,"
SET DIC(0)="AEMQ"
SET DIC("A")="Enter the Name of the Register: "
DO ^DIC
+3 IF Y=-1
SET APCLREG=""
WRITE !,"No Register Selected."
GOTO EOJ
+4 SET APCLREG=+Y
DATES KILL APCLED,APCLBD
+1 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Beginning Appointment Date"
+2 DO ^DIR
IF Y<1
GOTO REGISTER
SET APCLBD=Y
+3 KILL DIR
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Ending Appointment Date"
+4 DO ^DIR
IF Y<1
GOTO REGISTER
SET APCLED=Y
+5 ;
+6 IF APCLED<APCLBD
Begin DoDot:1
+7 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO DATES
+8 SET APCLSD=$$FMADD^XLFDT(APCLBD,-1)_".9999"
+9 ;
CLIN ;
+1 SET APCLCLN=""
+2 SET DIR(0)="S^A:ANY Clinic;S:One or more selected Clinics"
SET DIR("A")="Include patients with Appointments to"
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO DATES
+4 SET APCLCLN=Y
+5 IF APCLCLN="A"
KILL APCLCLN
GOTO ZIS
+6 ;get which clinics
+7 KILL APCLCLN
CLIN1 ;
+1 WRITE !
SET DIC="^SC("
SET DIC(0)="AEMZQ"
SET DIC("A")="Select CLINIC: "
+2 SET DIC("S")="I $P(^(0),U,3)=""C"""
DO ^DIC
KILL DIC
+3 IF Y=-1
IF '$DATA(APCLCLN)
GOTO CLIN
+4 IF X="^"
GOTO CLIN
+5 IF Y=""
IF $DATA(APCLCLN)
GOTO ZIS
+6 IF Y=-1
IF $DATA(APCLCLN)
GOTO ZIS
+7 IF X=""
IF '$DATA(APCLCLN)
GOTO CLIN
+8 SET APCLCLN(+Y)=""
+9 GOTO CLIN1
ZIS ;
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO CLIN
+3 SET XBRP="PRINT^APCLDMAP"
SET XBRC="PROC^APCLDMAP"
SET XBRX="EOJ^APCLDMAP"
SET XBNS="APCL"
+4 DO ^XBDBQUE
+5 QUIT
EOJ ;
+1 DO ^XBFMK
+2 KILL DIC,DIR
+3 DO EN^XBVK("APCL")
+4 QUIT
+5 ;
TEST ;
+1 DO BDMG(1,3040101,3041231,13)
+2 QUIT
BDMG(APCLREG,APCLBD,APCLED,APCLCLN) ;EP - GUI DMS Entry Point
+1 ;cmi/anch/maw added 10/19/2004
+2 SET APCLSD=$$FMADD^XLFDT(APCLBD,-1)_".9999"
+3 SET APCLGUI=1
+4 ;maw
NEW APCLOPT,APCLNOW,APCLIEN
+5 SET APCLOPT="List Patients on a Register w/an Appointment"
+6 DO NOW^%DTC
+7 SET APCLNOW=$GET(%)
+8 KILL DD,D0,DIC
+9 SET X=DUZ_$$NOW^XLFDT
+10 SET DIC("DR")=".02////"_DUZ_";.03////"_APCLNOW_";.06///"_$GET(APCLOPT)_";.07////R"
+11 SET DIC="^APCLGUIR("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9001004.4
+12 DO FILE^DICN
+13 KILL DIADD,DLAYGO,DIC,DA
+14 IF Y=-1
SET APCLIEN=-1
QUIT
+15 SET APCLIEN=+Y
+16 ;cmi/maw added
SET BDMGIEN=APCLIEN
+17 DO ^XBFMK
+18 KILL ZTSAVE
SET ZTSAVE("*")=""
+19 ;D GUIEP for interactive testing
+20 SET ZTIO=""
SET ZTDTH=$$NOW^XLFDT
SET ZTRTN="GUIEP^APCLDMAP"
SET ZTDESC="GUI DM REG APPT"
DO ^%ZTLOAD
+21 DO EOJ
+22 QUIT
GUIEP ;EP
+1 DO PROC
+2 KILL ^TMP($JOB,"APCLDMAP")
+3 SET IOM=80
+4 DO GUIR^XBLM("PRINT^APCLDMAP","^TMP($J,""APCLDMAP"",")
+5 SET X=0
SET C=0
FOR
SET X=$ORDER(^TMP($JOB,"APCLDMAP",X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET APCLDATA=^TMP($JOB,"APCLDMAP",X)
+7 IF APCLDATA="ZZZZZZZ"
SET APCLDATA=$CHAR(12)
+8 SET ^APCLGUIR(APCLIEN,11,X,0)=APCLDATA
SET C=C+1
End DoDot:1
+9 SET ^APCLGUIR(APCLIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
+10 SET DA=APCLIEN
SET DIK="^APCLGUIR("
DO IX1^DIK
+11 DO ENDLOG
+12 KILL ^TMP($JOB,"APCLDMAP")
+13 SET ZTREQ="@"
+14 QUIT
+15 ;
ENDLOG ;-- write the end of the log
+1 DO NOW^%DTC
+2 SET APCLNOW=$GET(%)
+3 SET DIE="^APCLGUIR("
SET DA=APCLIEN
SET DR=".04////"_APCLNOW_";.07////C"
+4 DO ^DIE
+5 KILL DIE,DR,DA
+6 QUIT
+7 ;
PROC ;
+1 SET APCLJ=$JOB
SET APCLH=$HOROLOG
+2 SET ^XTMP("APCLDMAP",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"REGISTER PTS WITH APPT"
+3 SET APCLDMX=0
FOR
SET APCLDMX=$ORDER(^ACM(41,"B",APCLREG,APCLDMX))
IF APCLDMX'=+APCLDMX
QUIT
Begin DoDot:1
+4 ;check to see if patient has an appt
+5 SET DFN=$PIECE(^ACM(41,APCLDMX,0),U,2)
+6 IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
QUIT
+7 SET APCLDMY=APCLSD
FOR
SET APCLDMY=$ORDER(^DPT(DFN,"S",APCLDMY))
IF APCLDMY=""!($PIECE(APCLDMY,".")>APCLED)
QUIT
Begin DoDot:2
+8 ;cancelled
IF $PIECE(^DPT(DFN,"S",APCLDMY,0),U,2)["C"
QUIT
+9 ;not a clinic of interest
IF $DATA(APCLCLN)
SET X=$PIECE(^DPT(DFN,"S",APCLDMY,0),U)
IF '$DATA(APCLCLN(X))
QUIT
+10 SET ^XTMP("APCLDMAP",APCLJ,APCLH,"APPTS",DFN,APCLDMY,$PIECE(^DPT(DFN,"S",APCLDMY,0),U))=""
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
DONE ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
SET DIR(0)="EO"
SET DIR("A")="End of report. PRESS ENTER"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(IOF)
WRITE @IOF
+3 KILL APCLTS,APCLS,APCLM,APCLET
+4 KILL ^XTMP("APCLDMAP",APCLJ,APCLH),APCLJ,APCLH
+5 QUIT
+6 ;
PRINT ;EP - called from xbdbque
+1 SET APCLIOSL=$SELECT($GET(APCLGUI):55,1:IOSL)
+2 KILL APCLQ
SET APCLPG=0
DO HEADER
+3 IF '$DATA(^XTMP("APCLDMAP",APCLJ,APCLH))
WRITE !!,"NO DATA TO REPORT",!
GOTO DONE
+4 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("APCLDMAP",APCLJ,APCLH,"APPTS",DFN))
IF DFN'=+DFN!($DATA(APCLQ))
QUIT
Begin DoDot:1
+5 SET APCLD=0
FOR
SET APCLD=$ORDER(^XTMP("APCLDMAP",APCLJ,APCLH,"APPTS",DFN,APCLD))
IF APCLD'=+APCLD!($DATA(APCLQ))
QUIT
Begin DoDot:2
+6 SET APCLC=0
FOR
SET APCLC=$ORDER(^XTMP("APCLDMAP",APCLJ,APCLH,"APPTS",DFN,APCLD,APCLC))
IF APCLC'=+APCLC!($DATA(APCLQ))
QUIT
Begin DoDot:3
+7 IF $Y>(APCLIOSL-4)
DO HEADER
IF $DATA(APCLQ)
QUIT
+8 WRITE !,$$HRN^AUPNPAT(DFN,DUZ(2)),?7,$EXTRACT($PIECE(^DPT(DFN,0),U),1,25),?38,$EXTRACT($PIECE(^SC(APCLC,0),U),1,20),?59,$$FMTE^XLFDT($PIECE(APCLD,".")),?72,$PIECE($$FMTE^XLFDT(APCLD,"2P")," ",2)
End DoDot:3
End DoDot:2
End DoDot:1
+9 DO DONE
+10 QUIT
+1 IF 'APCLPG
GOTO HEADER1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCLQ=""
QUIT
+1 IF $DATA(IOF)
WRITE @IOF
SET APCLPG=APCLPG+1
+2 IF $GET(APCLGUI)
IF APCLPG'=1
WRITE !,"ZZZZZZZ"
+3 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCLPG,!
+4 WRITE !,$$CTR("PATIENTS ON THE "_$PIECE(^ACM(41.1,APCLREG,0),U)_" REGISTER WITH AN APPOINTMENT",80),!
+5 SET X="Appointment Dates: "_$$FMTE^XLFDT(APCLBD)_" to "_$$FMTE^XLFDT(APCLED)
WRITE $$CTR(X,80),!
+6 WRITE $$CTR("CLINICS: "_$SELECT($DATA(APCLCLN):"USER SELECTED",1:"ANY"),80),!
+7 WRITE !,"HRN",?7,"PATIENT NAME",?38,"CLINIC NAME",?59,"DATE",?72,"TIME"
+8 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+9 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR("A")="End of report. Press Enter"
SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
POST ;
+1 NEW X
+2 SET X=$$ADD^XPDMENU("APCL M MAIN DM MENU","APCL DM REG APPT CLN","APCL")
+3 IF 'X
WRITE "Attempt to new appt list of reg pats failed.."
HANG 3
+4 QUIT
