- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMXTU 6372 printed Jan 18, 2025@02:51:43 Page 2
- 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