PXRMXTU ; SLC/PJH - Reminder Reports Template Update ;07/30/2009
;;2.0;CLINICAL REMINDERS;**4,6,12**;Feb 04, 2005;Build 73
;
; Called from PXRMYD,PXRMXD (also at UPD from PXRMXPR/PXRMYPR)
;
;Option to create a new template
;-------------------------------
START N PXRMASK,MSG D ASK(.PXRMASK)
I $G(PXRMASK)="Y" D SAVE
EXIT Q
;
;Ask name for new template
;-------------------------
SAVE N X,Y,DIC,DLAYGO
SAV1 S DIC=810.1,DLAYGO=DIC,DIC(0)="QAELX"
S DIC("A")="STORE REPORT LOGIC IN TEMPLATE NAME: "
W !
D ^DIC
I X="" W !,"A template name must be entered" G SAV1
I X=(U_U) S DTOUT=1
I Y=-1 S DUOUT=1 W !,"Details not saved" Q
I $D(DTOUT)!$D(DUOUT) Q
;Check
I ($P(Y,U,3)'=1) W !,"This template name already exists" G SAV1
;Get template name and title
S PXRMTMP=Y,TITLE=$P($G(^PXRMPT(810.1,$P(Y,U),0)),U,2)
S $P(PXRMTMP,U,3)=TITLE
;File details
D FILE(Y,1,0)
;File not saved message
I $D(MSG) D Q
.N DA,DIK
.S DA=$P(Y,U),DIK="^PXRMPT(810.1," D ^DIK
.D MESS^PXRMXTF(4,$P(PXRMTMP,U,2))
;File saved message
D MESS^PXRMXTF(1,$P(PXRMTMP,U,2))
Q
;
;File template detail
;--------------------
FILE(INP,UPD,CLR) ;
N CNT,FDA,FDAIEN,FNO,IC,INT,MODE,NAME,X
S FDAIEN(1)=$P(INP,U),NAME=$P(INP,U,2)
;Save exit flags - needed for rollback
N DUOUT,DTOUT
;
;Update or Add
S MODE=$S(UPD:(FDAIEN(1)_","),1:"+1,")
;Delete entries from existing template
I CLR D
.N DA S DA=0
.F S DA=$O(^PXRMPT(810.1,FDAIEN(1),DA)) Q:'DA D
..K ^PXRMPT(810.1,FDAIEN(1),DA)
;
I PXRMSEL="L" S X=PXRMLCSC,PXRMLCSC=$P(PXRMLCSC,U)
;
N MREF,XREF
D XREF^PXRMXTB
;
;Save single fields into FDA
F IC="NAME","PXRMLCSC","PXRMPRIM","PXRMREP","PXRMSEL","PXRMTYP","PXRMPML","PXRMPER" D
.S FDA(810.1,MODE,XREF(IC))=$G(@IC)
F IC="PXRMFD","PXRMSCAT","RUN","TITLE" D
.S FDA(810.1,MODE,XREF(IC))=$G(@IC)
;Save Owner value
S FDA(810.1,MODE,15)=$S(+$G(PXRMOWN)>0:PXRMOWN,1:DUZ)
;
I PXRMSEL="L" S PXRMLCSC=X
;
;Save Arrays into FDA
;
;Reminder Items
S CNT=1
D SUB1(.PXRMREM,"810.12",1)
;Save Facility codes
D SUB1(.PXRMFAC,"810.13",1)
;Save Provider codes
D SUB1(.PXRMPRV,"810.14",1)
;Save Patient codes
D SUB1(.PXRMPAT,"810.16",1)
;Save OE/RR Team codes
D SUB1(.PXRMOTM,"810.17",1)
;Save PCMM Team codes
D SUB1(.PXRMPCM,"810.18",1)
;Save Hospital Location codes
D SUB1(.PXRMLCHL,"810.11",2)
;Save Clinic Stop codes
D SUB1(.PXRMCS,"810.111",2)
;Save Clinic groups
D SUB1(.PXRMCGRP,"810.112",1)
;Save Reminder Categories
D SUB1(.PXRMRCAT,"810.113",1)
;Save Patient lists
D SUB1(.PXRMLIST,"810.114",1)
;
;Update template file
D UPDATE^DIE("S","FDA","FDAIEN","MSG")
;
I $D(MSG) D
.W !!,"Update failed, UPDATE^DIE returned the following error message:"
.S IC="MSG"
.F S IC=$Q(@IC) Q:IC="" W !,IC,"=",@IC
.W !,"Examine the above error message for the reason.",!
.H 2
Q
;
;Save arrays into FDA
;--------------------
SUB1(OUTPUT,VAR,PIECE) ;
S IC=""
;This is use for saving individual reminders back to the original
;template
I VAR=810.12,$D(PXRMTREM($P(INP,U)))>0 D Q
.F S IC=$O(PXRMTREM($P(INP,U),IC)) Q:IC="" D
..S INT=$P(PXRMTREM($P(INP,U),IC),U,PIECE),CNT=CNT+1
..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT
..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC
;
;This is use for saving individual reminders category back to the
;original template
I VAR=810.113,$D(PXRMTCAT($P(INP,U)))>0 D Q
.F S IC=$O(PXRMTCAT($P(INP,U),IC)) Q:IC="" D
..S INT=$P(PXRMTCAT($P(INP,U),IC),U,PIECE),CNT=CNT+1
..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT
..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC
;
;this is use for saving everything else to the template
F S IC=$O(OUTPUT(IC)) Q:IC="" D
.S INT=$P(OUTPUT(IC),U,PIECE),CNT=CNT+1
.S FDA(VAR,"+"_CNT_","_MODE,.01)=INT
.;Save Display order for reminders and categories
.I (VAR=810.12)!(VAR=810.113) S FDA(VAR,"+"_CNT_","_MODE,.02)=IC
Q
;
;Save Service Categories into FDA
;--------------------------------
SUB2(FLD,VAR) ;
F IC=1:1 S INT=$E(@FLD,IC) Q:INT="" D
.S CNT=CNT+1,FDA(VAR,"+"_CNT_","_MODE,.01)=INT
Q
;
;
;Option to save a new template
;-----------------------------
ASK(YESNO) ;
N X,Y,TEXT
K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="YA0"
S DIR("A")="Create a new report template: "
S DIR("B")="N"
S DIR("?")="Enter Y or N. For detailed help type ??"
S DIR("??")=U_"D HELP^PXRMXTU(1)"
W !
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) Q
S YESNO=$E(Y(0))
Q
;
;General help text routine. Write out the text in the HTEXT array
;----------------------------------------------------------------
HELP(CALL) ;
N HTEXT
N DIWF,DIWL,DIWR,IC
S DIWF="C70",DIWL=0,DIWR=70
;
I CALL=1 D
.S HTEXT(1)="Enter 'Y' to save the reporting parameters as a report"
.S HTEXT(2)="template from which the report may be re-run in future."
;
K ^UTILITY($J,"W")
S IC=""
F S IC=$O(HTEXT(IC)) Q:IC="" D
. S X=HTEXT(IC)
. D ^DIWP
W !
S IC=0
F S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC="" D
. W !,^UTILITY($J,"W",0,IC,0)
K ^UTILITY($J,"W")
W !
Q
;
;Save template info to new name
;------------------------------
COPY N PXRMLCSC,PXRMPRIM,PRRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS
N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS
;Load arrays from original template PXRMTMP
D LOAD^PXRMXT I $D(MSG) Q
;Clear last run date
S RUN=""
;Save arrays to new ID
D FILE(NEWTEMP,0)
Q
;
;Update print template last run date (called from PXRMYPR/PXRMXPR)
;-----------------------------------------------------------------
UPD S ^PXRMPT(810.1,$P(PXRMTMP,U),7)=PXRMXST
Q
;
;Called as an input transform for 810.1/NAME
;-------------------------------------------
NAME Q:'$D(X) Q:X="" Q:$G(PXRMTYP)=""
;Disallow duplicate template names
Q:'$D(^PXRMPT(810.1,"B",X))
W !,"This template name already exists" K X
Q
;
;Called as an input transform for 810.1/PXRMFD
;---------------------------------------------
INP Q:'$D(X) Q:X=""
;If inpatient wards prompt only for Admissions/Current Patients
I $G(PXRMINP),"FP"[X D
.W !,"Select either Inpatient Admissions or Current Inpatients" K X
;If other locations prompt only for Prior visits/Future Appts
I '$G(PXRMINP),"AC"[X D
.W !,"Select either Future Appointments or Prior Visits" K X
Q
PXRMXTU ; SLC/PJH - Reminder Reports Template Update ;07/30/2009
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12**;Feb 04, 2005;Build 73
+2 ;
+3 ; Called from PXRMYD,PXRMXD (also at UPD from PXRMXPR/PXRMYPR)
+4 ;
+5 ;Option to create a new template
+6 ;-------------------------------
START NEW PXRMASK,MSG
DO ASK(.PXRMASK)
+1 IF $GET(PXRMASK)="Y"
DO SAVE
EXIT QUIT
+1 ;
+2 ;Ask name for new template
+3 ;-------------------------
SAVE NEW X,Y,DIC,DLAYGO
SAV1 SET DIC=810.1
SET DLAYGO=DIC
SET DIC(0)="QAELX"
+1 SET DIC("A")="STORE REPORT LOGIC IN TEMPLATE NAME: "
+2 WRITE !
+3 DO ^DIC
+4 IF X=""
WRITE !,"A template name must be entered"
GOTO SAV1
+5 IF X=(U_U)
SET DTOUT=1
+6 IF Y=-1
SET DUOUT=1
WRITE !,"Details not saved"
QUIT
+7 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+8 ;Check
+9 IF ($PIECE(Y,U,3)'=1)
WRITE !,"This template name already exists"
GOTO SAV1
+10 ;Get template name and title
+11 SET PXRMTMP=Y
SET TITLE=$PIECE($GET(^PXRMPT(810.1,$PIECE(Y,U),0)),U,2)
+12 SET $PIECE(PXRMTMP,U,3)=TITLE
+13 ;File details
+14 DO FILE(Y,1,0)
+15 ;File not saved message
+16 IF $DATA(MSG)
Begin DoDot:1
+17 NEW DA,DIK
+18 SET DA=$PIECE(Y,U)
SET DIK="^PXRMPT(810.1,"
DO ^DIK
+19 DO MESS^PXRMXTF(4,$PIECE(PXRMTMP,U,2))
End DoDot:1
QUIT
+20 ;File saved message
+21 DO MESS^PXRMXTF(1,$PIECE(PXRMTMP,U,2))
+22 QUIT
+23 ;
+24 ;File template detail
+25 ;--------------------
FILE(INP,UPD,CLR) ;
+1 NEW CNT,FDA,FDAIEN,FNO,IC,INT,MODE,NAME,X
+2 SET FDAIEN(1)=$PIECE(INP,U)
SET NAME=$PIECE(INP,U,2)
+3 ;Save exit flags - needed for rollback
+4 NEW DUOUT,DTOUT
+5 ;
+6 ;Update or Add
+7 SET MODE=$SELECT(UPD:(FDAIEN(1)_","),1:"+1,")
+8 ;Delete entries from existing template
+9 IF CLR
Begin DoDot:1
+10 NEW DA
SET DA=0
+11 FOR
SET DA=$ORDER(^PXRMPT(810.1,FDAIEN(1),DA))
IF 'DA
QUIT
Begin DoDot:2
+12 KILL ^PXRMPT(810.1,FDAIEN(1),DA)
End DoDot:2
End DoDot:1
+13 ;
+14 IF PXRMSEL="L"
SET X=PXRMLCSC
SET PXRMLCSC=$PIECE(PXRMLCSC,U)
+15 ;
+16 NEW MREF,XREF
+17 DO XREF^PXRMXTB
+18 ;
+19 ;Save single fields into FDA
+20 FOR IC="NAME","PXRMLCSC","PXRMPRIM","PXRMREP","PXRMSEL","PXRMTYP","PXRMPML","PXRMPER"
Begin DoDot:1
+21 SET FDA(810.1,MODE,XREF(IC))=$GET(@IC)
End DoDot:1
+22 FOR IC="PXRMFD","PXRMSCAT","RUN","TITLE"
Begin DoDot:1
+23 SET FDA(810.1,MODE,XREF(IC))=$GET(@IC)
End DoDot:1
+24 ;Save Owner value
+25 SET FDA(810.1,MODE,15)=$SELECT(+$GET(PXRMOWN)>0:PXRMOWN,1:DUZ)
+26 ;
+27 IF PXRMSEL="L"
SET PXRMLCSC=X
+28 ;
+29 ;Save Arrays into FDA
+30 ;
+31 ;Reminder Items
+32 SET CNT=1
+33 DO SUB1(.PXRMREM,"810.12",1)
+34 ;Save Facility codes
+35 DO SUB1(.PXRMFAC,"810.13",1)
+36 ;Save Provider codes
+37 DO SUB1(.PXRMPRV,"810.14",1)
+38 ;Save Patient codes
+39 DO SUB1(.PXRMPAT,"810.16",1)
+40 ;Save OE/RR Team codes
+41 DO SUB1(.PXRMOTM,"810.17",1)
+42 ;Save PCMM Team codes
+43 DO SUB1(.PXRMPCM,"810.18",1)
+44 ;Save Hospital Location codes
+45 DO SUB1(.PXRMLCHL,"810.11",2)
+46 ;Save Clinic Stop codes
+47 DO SUB1(.PXRMCS,"810.111",2)
+48 ;Save Clinic groups
+49 DO SUB1(.PXRMCGRP,"810.112",1)
+50 ;Save Reminder Categories
+51 DO SUB1(.PXRMRCAT,"810.113",1)
+52 ;Save Patient lists
+53 DO SUB1(.PXRMLIST,"810.114",1)
+54 ;
+55 ;Update template file
+56 DO UPDATE^DIE("S","FDA","FDAIEN","MSG")
+57 ;
+58 IF $DATA(MSG)
Begin DoDot:1
+59 WRITE !!,"Update failed, UPDATE^DIE returned the following error message:"
+60 SET IC="MSG"
+61 FOR
SET IC=$QUERY(@IC)
IF IC=""
QUIT
WRITE !,IC,"=",@IC
+62 WRITE !,"Examine the above error message for the reason.",!
+63 HANG 2
End DoDot:1
+64 QUIT
+65 ;
+66 ;Save arrays into FDA
+67 ;--------------------
SUB1(OUTPUT,VAR,PIECE) ;
+1 SET IC=""
+2 ;This is use for saving individual reminders back to the original
+3 ;template
+4 IF VAR=810.12
IF $DATA(PXRMTREM($PIECE(INP,U)))>0
Begin DoDot:1
+5 FOR
SET IC=$ORDER(PXRMTREM($PIECE(INP,U),IC))
IF IC=""
QUIT
Begin DoDot:2
+6 SET INT=$PIECE(PXRMTREM($PIECE(INP,U),IC),U,PIECE)
SET CNT=CNT+1
+7 SET FDA(VAR,"+"_CNT_","_MODE,.01)=INT
+8 SET FDA(VAR,"+"_CNT_","_MODE,.02)=IC
End DoDot:2
End DoDot:1
QUIT
+9 ;
+10 ;This is use for saving individual reminders category back to the
+11 ;original template
+12 IF VAR=810.113
IF $DATA(PXRMTCAT($PIECE(INP,U)))>0
Begin DoDot:1
+13 FOR
SET IC=$ORDER(PXRMTCAT($PIECE(INP,U),IC))
IF IC=""
QUIT
Begin DoDot:2
+14 SET INT=$PIECE(PXRMTCAT($PIECE(INP,U),IC),U,PIECE)
SET CNT=CNT+1
+15 SET FDA(VAR,"+"_CNT_","_MODE,.01)=INT
+16 SET FDA(VAR,"+"_CNT_","_MODE,.02)=IC
End DoDot:2
End DoDot:1
QUIT
+17 ;
+18 ;this is use for saving everything else to the template
+19 FOR
SET IC=$ORDER(OUTPUT(IC))
IF IC=""
QUIT
Begin DoDot:1
+20 SET INT=$PIECE(OUTPUT(IC),U,PIECE)
SET CNT=CNT+1
+21 SET FDA(VAR,"+"_CNT_","_MODE,.01)=INT
+22 ;Save Display order for reminders and categories
+23 IF (VAR=810.12)!(VAR=810.113)
SET FDA(VAR,"+"_CNT_","_MODE,.02)=IC
End DoDot:1
+24 QUIT
+25 ;
+26 ;Save Service Categories into FDA
+27 ;--------------------------------
SUB2(FLD,VAR) ;
+1 FOR IC=1:1
SET INT=$EXTRACT(@FLD,IC)
IF INT=""
QUIT
Begin DoDot:1
+2 SET CNT=CNT+1
SET FDA(VAR,"+"_CNT_","_MODE,.01)=INT
End DoDot:1
+3 QUIT
+4 ;
+5 ;
+6 ;Option to save a new template
+7 ;-----------------------------
ASK(YESNO) ;
+1 NEW X,Y,TEXT
+2 KILL DIROUT,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="YA0"
+4 SET DIR("A")="Create a new report template: "
+5 SET DIR("B")="N"
+6 SET DIR("?")="Enter Y or N. For detailed help type ??"
+7 SET DIR("??")=U_"D HELP^PXRMXTU(1)"
+8 WRITE !
+9 DO ^DIR
KILL DIR
+10 IF $DATA(DIROUT)
SET DTOUT=1
+11 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+12 SET YESNO=$EXTRACT(Y(0))
+13 QUIT
+14 ;
+15 ;General help text routine. Write out the text in the HTEXT array
+16 ;----------------------------------------------------------------
HELP(CALL) ;
+1 NEW HTEXT
+2 NEW DIWF,DIWL,DIWR,IC
+3 SET DIWF="C70"
SET DIWL=0
SET DIWR=70
+4 ;
+5 IF CALL=1
Begin DoDot:1
+6 SET HTEXT(1)="Enter 'Y' to save the reporting parameters as a report"
+7 SET HTEXT(2)="template from which the report may be re-run in future."
End DoDot:1
+8 ;
+9 KILL ^UTILITY($JOB,"W")
+10 SET IC=""
+11 FOR
SET IC=$ORDER(HTEXT(IC))
IF IC=""
QUIT
Begin DoDot:1
+12 SET X=HTEXT(IC)
+13 DO ^DIWP
End DoDot:1
+14 WRITE !
+15 SET IC=0
+16 FOR
SET IC=$ORDER(^UTILITY($JOB,"W",0,IC))
IF IC=""
QUIT
Begin DoDot:1
+17 WRITE !,^UTILITY($JOB,"W",0,IC,0)
End DoDot:1
+18 KILL ^UTILITY($JOB,"W")
+19 WRITE !
+20 QUIT
+21 ;
+22 ;Save template info to new name
+23 ;------------------------------
COPY NEW PXRMLCSC,PXRMPRIM,PRRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS
+1 NEW PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS
+2 ;Load arrays from original template PXRMTMP
+3 DO LOAD^PXRMXT
IF $DATA(MSG)
QUIT
+4 ;Clear last run date
+5 SET RUN=""
+6 ;Save arrays to new ID
+7 DO FILE(NEWTEMP,0)
+8 QUIT
+9 ;
+10 ;Update print template last run date (called from PXRMYPR/PXRMXPR)
+11 ;-----------------------------------------------------------------
UPD SET ^PXRMPT(810.1,$PIECE(PXRMTMP,U),7)=PXRMXST
+1 QUIT
+2 ;
+3 ;Called as an input transform for 810.1/NAME
+4 ;-------------------------------------------
NAME IF '$DATA(X)
QUIT
IF X=""
QUIT
IF $GET(PXRMTYP)=""
QUIT
+1 ;Disallow duplicate template names
+2 IF '$DATA(^PXRMPT(810.1,"B",X))
QUIT
+3 WRITE !,"This template name already exists"
KILL X
+4 QUIT
+5 ;
+6 ;Called as an input transform for 810.1/PXRMFD
+7 ;---------------------------------------------
INP IF '$DATA(X)
QUIT
IF X=""
QUIT
+1 ;If inpatient wards prompt only for Admissions/Current Patients
+2 IF $GET(PXRMINP)
IF "FP"[X
Begin DoDot:1
+3 WRITE !,"Select either Inpatient Admissions or Current Inpatients"
KILL X
End DoDot:1
+4 ;If other locations prompt only for Prior visits/Future Appts
+5 IF '$GET(PXRMINP)
IF "AC"[X
Begin DoDot:1
+6 WRITE !,"Select either Future Appointments or Prior Visits"
KILL X
End DoDot:1
+7 QUIT
