PXRMXT ; SLC/PJH - Reminder Reports Template Load ;01/28/2013
;;2.0;CLINICAL REMINDERS;**4,26**;Feb 04, 2005;Build 404
;
; Called from PXRMYD,PXRMXD
;
;Select Template
;---------------
START N X,Y,CNT,FOUND,PXRMFLD,DIC,MSG
K DIROUT,DIRUT,DTOUT,DUOUT
S PXRMTMP="",FOUND=0
;
;Check if any templates exist for this report type
Q:'$$FIND(PXRMTYP)
;
;Select template required
W !
S CNT=0,DIC=810.1,DIC(0)="AEQMZ"
S DIC("A")="Select an existing REPORT TEMPLATE or return to continue: "
S DIC("S")="I $P(^PXRMPT(810.1,+Y,0),U,3)=PXRMTYP"
D ^DIC
I X=(U_U) S DTOUT=1
I '$D(DTOUT),('$D(DUOUT)) D
.I +Y'=-1 D Q
..S CNT=CNT+1,ARRAY(CNT)=Y_U_Y(0,0)_U_$P(Y(0),U,3)
K DIC
;
;Load template into local array
I (+Y'=-1)&('$D(DTOUT))&('$D(DUOUT)) D
.L +^PXRMPT(810.1,$P(Y,U)):DILOCKTM
.E W !!?5,"Another user is editing this entry." S DUOUT=1 Q
.;Load template into an array
.S PXRMTMP=Y_U_$P(Y(0),U,2) D LOAD
.L -^PXRMPT(810.1,$P(PXRMTMP,U))
.;Exit if problem loading template
.I $D(MSG) S DTOUT=1 Q
.;Display Template information
.D:'$D(MSG) ^PXRMXTD
;
EXIT Q
;
;Check if any templates exist for this report type
;-------------------------------------------------
FIND(TYP) ;
N SUB,FOUND
S SUB=0,FOUND=0
F S SUB=$O(^PXRMPT(810.1,SUB)) Q:'SUB D Q:FOUND
.I $P($G(^PXRMPT(810.1,SUB,0)),U,3)=TYP S FOUND=1
Q FOUND
;
;
;Load variables from report template (both INT and EXT)
;------------------------------------------------------
LOAD N ARRAY
D GETS^DIQ(810.1,$P(PXRMTMP,U),"**","IE","ARRAY","MSG")
I $D(MSG) D Q
.W !!,"File read failed, GETS^DIQ returned the following error message:"
.N IC S IC="MSG"
.F S IC=$Q(@IC) Q:IC="" W !,IC,"=",@IC
.W !,"Examine the above error message for the reason.",!
.H 2
;
N MREF,ORDER,ORDERC,SUB,SUB1,XREF
;
S SUB1=$O(ARRAY(810.1,""))
D XREF^PXRMXTB
S SUB="" F S SUB=$O(XREF(SUB)) Q:SUB="" D
.S @SUB=$G(ARRAY(810.1,SUB1,XREF(SUB),"I"))
;
S PXRMFLD=$G(ARRAY(810.1,SUB1,XREF("PXRMSEL"),"E"))
S RUN=$G(ARRAY(810.1,SUB1,XREF("RUN"),"E"))
;Update name if template has been renamed
S $P(PXRMTMP,U,2)=$G(ARRAY(810.1,SUB1,XREF("NAME"),"E"))
S TITLE=$G(ARRAY(810.1,SUB1,XREF("TITLE"),"E")),$P(PXRMTMP,U,3)=TITLE
;
MULT ;Clear multiple field arrays
K PXRMREM,PXRMPAT,PXRMPRV,PXRMOTM,PXRMFAC,PXRMLCHL,PXRMCS,PXRMCGRP
K PXRMFACN,PXRMCSN,PXRMCGRN,PXRMRCAT,REMINDER
;
;Load Multiple fields
D SUB(.PXRMREM,810.12,"REMINDER",1)
;Load Patients
D SUB(.PXRMPAT,810.16,"PATIENT",1)
;Load Providers
D SUB(.PXRMPRV,810.14,"PROVIDER",1)
;Load OE/RR Teams
D SUB(.PXRMOTM,810.17,"OERR TEAM",1)
;Load PCMM Teams
D SUB(.PXRMPCM,810.18,"PCMM TEAM",1)
;Load Facility codes
D SUB(.PXRMFAC,810.13,"FACILITY",1)
;Load Hospital Location codes
D SUB(.PXRMLCHL,810.11,"LOCATION",2)
;Load Clinic Stop codes
D SUB(.PXRMCS,810.111,"STOP CODE",2)
;Load Clinic Groups
D SUB(.PXRMCGRP,810.112,"CLINIC GROUP",1)
;Load Reminder Categories
D SUB(.PXRMRCAT,810.113,"REMINDER CATEGORY",1)
;Load Patient lists
D SUB(.PXRMLIST,810.114,"PXRMLIST",1)
;
;Build PXRMFACN/PXRMLOCN array IEN's and counters NHL/NFAC
D NUM
;
;Build Service Category array
I $L(PXRMSCAT)>0 F IC=1:1:$L(PXRMSCAT,",") S PXRMSCAT($P(PXRMSCAT,",",IC))=""
;
;Add Descriptions for Reminders
D DES(.PXRMREM,"^PXD(811.9",4)
;Add Descriptions for Reminder Categories
D DES(.PXRMRCAT,"^PXRMD(811.7",4)
;Add Descriptions for Teams
D DES(.PXRMOTM,"^OR(100.21",3)
;Add Display Codes for Stops
D CODE(.PXRMCS,"^DIC(40.7",3)
;
;Sort Reminders into display order
D SORT(.PXRMREM,.ORDER)
;Sort Reminders categories into display order
D SORT(.PXRMRCAT,.ORDERC)
;
;Combine individual reminders and category reminders
D MERGE^PXRMXS1
Q
;
;
;Extract INTernal and EXTernal format from ARRAY
;-----------------------------------------------
SUB(OUTPUT,SUB,VAR,ORD) ;
K OUTPUT
N IC,INT,EXT,SUB1,DISP
S SUB1="",IC=0
F S SUB1=$O(ARRAY(SUB,SUB1)) Q:SUB1="" D
.S INT=$P($G(ARRAY(SUB,SUB1,MREF(VAR),"I")),";")
.S EXT=$G(ARRAY(SUB,SUB1,MREF(VAR),"E"))
.S IC=IC+1
.I ORD=1 S OUTPUT(IC)=INT_U_EXT
.I ORD'=1 S OUTPUT(IC)=EXT_U_INT
.I (VAR'="REMINDER")&(VAR'="REMINDER CATEGORY") Q
.;Get display order
.S DISP=$G(ARRAY(SUB,SUB1,MREF("DISPLAY ORDER"),"I"))
.;Store in PXRMREM for display
.S OUTPUT(IC)=OUTPUT(IC)_U_DISP
.;Put reminders with no sequence number last
.I DISP="" S DISP=99
.;Create order array for sorting entries later
.I VAR="REMINDER" S ORDER(DISP,IC)=""
.I VAR="REMINDER CATEGORY" S ORDERC(DISP,IC)=""
Q
;
;Build array PXRMFACN and NFAC
;-----------------------------
NUM N IC,FACN,FACNAM
K PXRMLOCN,PXRMCSN,PXRMCGRN,PXRMFACN
S IC=""
F S IC=$O(PXRMFAC(IC)) Q:IC="" D
.S FACN=$P(PXRMFAC(IC),U),FACNAM=$P(PXRMFAC(IC),U,2)
.S PXRMFACN(FACN)=FACNAM_U_FACN,NFAC=IC
; Build Array PXRMLOCN and NHL
N LOCN
F S IC=$O(PXRMLCHL(IC)) Q:IC="" D
.S LOCN=$P(PXRMLCHL(IC),U,2)
.S PXRMLOCN(LOCN)=IC,NHL=IC
; Build Array PXRMCSN and NCS
N CSN
F S IC=$O(PXRMCS(IC)) Q:IC="" D
.S CSN=$P(PXRMCS(IC),U,2)
.S PXRMCSN(CSN)=IC,NCS=IC
; Build Array PXRMCGRN and NCGRP
N GRPN
F S IC=$O(PXRMCGRP(IC)) Q:IC="" D
.S GRPN=$P(PXRMCGRP(IC),U,1)
.S PXRMCGRN(GRPN)=IC,NCGRP=IC
Q
;
;Add print name to OUTPUT array
;-------------------------------
DES(OUTPUT,GLOB,POSN) ;
N IC,IEN,DES
S IC=""
F S IC=$O(OUTPUT(IC)) Q:IC="" D
.S IEN=$P(OUTPUT(IC),U,1)
.X "S DES=$P($G("_GLOB_",IEN,0)),U,3)"
.S $P(OUTPUT(IC),U,POSN)=DES
Q
;
;Add stop code to OUTPUT array
;-------------------------------
CODE(OUTPUT,GLOB,POSN) ;
N IC,IEN,CODE
S IC=""
F S IC=$O(OUTPUT(IC)) Q:IC="" D
.S IEN=$P(OUTPUT(IC),U,2)
.X "S CODE=$P($G("_GLOB_",IEN,0)),U,2)"
.S $P(OUTPUT(IC),U,POSN)=CODE
Q
;
;Sort reminders into display order (allow for duplicates)
;--------------------------------------------------------
SORT(INPUT,ORDER) ;
N IC,DISP,OUTPUT,IC1
S DISP="",IC1=0
F S DISP=$O(ORDER(DISP)) Q:DISP="" D
.S IC=""
.F S IC=$O(ORDER(DISP,IC)) Q:IC="" D
..S IC1=IC1+1,OUTPUT(IC1)=INPUT(IC)
; Move results back
K INPUT M INPUT=OUTPUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMXT 6226 printed Oct 16, 2024@17:51:14 Page 2
PXRMXT ; SLC/PJH - Reminder Reports Template Load ;01/28/2013
+1 ;;2.0;CLINICAL REMINDERS;**4,26**;Feb 04, 2005;Build 404
+2 ;
+3 ; Called from PXRMYD,PXRMXD
+4 ;
+5 ;Select Template
+6 ;---------------
START NEW X,Y,CNT,FOUND,PXRMFLD,DIC,MSG
+1 KILL DIROUT,DIRUT,DTOUT,DUOUT
+2 SET PXRMTMP=""
SET FOUND=0
+3 ;
+4 ;Check if any templates exist for this report type
+5 if '$$FIND(PXRMTYP)
QUIT
+6 ;
+7 ;Select template required
+8 WRITE !
+9 SET CNT=0
SET DIC=810.1
SET DIC(0)="AEQMZ"
+10 SET DIC("A")="Select an existing REPORT TEMPLATE or return to continue: "
+11 SET DIC("S")="I $P(^PXRMPT(810.1,+Y,0),U,3)=PXRMTYP"
+12 DO ^DIC
+13 IF X=(U_U)
SET DTOUT=1
+14 IF '$DATA(DTOUT)
IF ('$DATA(DUOUT))
Begin DoDot:1
+15 IF +Y'=-1
Begin DoDot:2
+16 SET CNT=CNT+1
SET ARRAY(CNT)=Y_U_Y(0,0)_U_$PIECE(Y(0),U,3)
End DoDot:2
QUIT
End DoDot:1
+17 KILL DIC
+18 ;
+19 ;Load template into local array
+20 IF (+Y'=-1)&('$DATA(DTOUT))&('$DATA(DUOUT))
Begin DoDot:1
+21 LOCK +^PXRMPT(810.1,$PIECE(Y,U)):DILOCKTM
+22 IF '$TEST
WRITE !!?5,"Another user is editing this entry."
SET DUOUT=1
QUIT
+23 ;Load template into an array
+24 SET PXRMTMP=Y_U_$PIECE(Y(0),U,2)
DO LOAD
+25 LOCK -^PXRMPT(810.1,$PIECE(PXRMTMP,U))
+26 ;Exit if problem loading template
+27 IF $DATA(MSG)
SET DTOUT=1
QUIT
+28 ;Display Template information
+29 if '$DATA(MSG)
DO ^PXRMXTD
End DoDot:1
+30 ;
EXIT QUIT
+1 ;
+2 ;Check if any templates exist for this report type
+3 ;-------------------------------------------------
FIND(TYP) ;
+1 NEW SUB,FOUND
+2 SET SUB=0
SET FOUND=0
+3 FOR
SET SUB=$ORDER(^PXRMPT(810.1,SUB))
if 'SUB
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^PXRMPT(810.1,SUB,0)),U,3)=TYP
SET FOUND=1
End DoDot:1
if FOUND
QUIT
+5 QUIT FOUND
+6 ;
+7 ;
+8 ;Load variables from report template (both INT and EXT)
+9 ;------------------------------------------------------
LOAD NEW ARRAY
+1 DO GETS^DIQ(810.1,$PIECE(PXRMTMP,U),"**","IE","ARRAY","MSG")
+2 IF $DATA(MSG)
Begin DoDot:1
+3 WRITE !!,"File read failed, GETS^DIQ returned the following error message:"
+4 NEW IC
SET IC="MSG"
+5 FOR
SET IC=$QUERY(@IC)
if IC=""
QUIT
WRITE !,IC,"=",@IC
+6 WRITE !,"Examine the above error message for the reason.",!
+7 HANG 2
End DoDot:1
QUIT
+8 ;
+9 NEW MREF,ORDER,ORDERC,SUB,SUB1,XREF
+10 ;
+11 SET SUB1=$ORDER(ARRAY(810.1,""))
+12 DO XREF^PXRMXTB
+13 SET SUB=""
FOR
SET SUB=$ORDER(XREF(SUB))
if SUB=""
QUIT
Begin DoDot:1
+14 SET @SUB=$GET(ARRAY(810.1,SUB1,XREF(SUB),"I"))
End DoDot:1
+15 ;
+16 SET PXRMFLD=$GET(ARRAY(810.1,SUB1,XREF("PXRMSEL"),"E"))
+17 SET RUN=$GET(ARRAY(810.1,SUB1,XREF("RUN"),"E"))
+18 ;Update name if template has been renamed
+19 SET $PIECE(PXRMTMP,U,2)=$GET(ARRAY(810.1,SUB1,XREF("NAME"),"E"))
+20 SET TITLE=$GET(ARRAY(810.1,SUB1,XREF("TITLE"),"E"))
SET $PIECE(PXRMTMP,U,3)=TITLE
+21 ;
MULT ;Clear multiple field arrays
+1 KILL PXRMREM,PXRMPAT,PXRMPRV,PXRMOTM,PXRMFAC,PXRMLCHL,PXRMCS,PXRMCGRP
+2 KILL PXRMFACN,PXRMCSN,PXRMCGRN,PXRMRCAT,REMINDER
+3 ;
+4 ;Load Multiple fields
+5 DO SUB(.PXRMREM,810.12,"REMINDER",1)
+6 ;Load Patients
+7 DO SUB(.PXRMPAT,810.16,"PATIENT",1)
+8 ;Load Providers
+9 DO SUB(.PXRMPRV,810.14,"PROVIDER",1)
+10 ;Load OE/RR Teams
+11 DO SUB(.PXRMOTM,810.17,"OERR TEAM",1)
+12 ;Load PCMM Teams
+13 DO SUB(.PXRMPCM,810.18,"PCMM TEAM",1)
+14 ;Load Facility codes
+15 DO SUB(.PXRMFAC,810.13,"FACILITY",1)
+16 ;Load Hospital Location codes
+17 DO SUB(.PXRMLCHL,810.11,"LOCATION",2)
+18 ;Load Clinic Stop codes
+19 DO SUB(.PXRMCS,810.111,"STOP CODE",2)
+20 ;Load Clinic Groups
+21 DO SUB(.PXRMCGRP,810.112,"CLINIC GROUP",1)
+22 ;Load Reminder Categories
+23 DO SUB(.PXRMRCAT,810.113,"REMINDER CATEGORY",1)
+24 ;Load Patient lists
+25 DO SUB(.PXRMLIST,810.114,"PXRMLIST",1)
+26 ;
+27 ;Build PXRMFACN/PXRMLOCN array IEN's and counters NHL/NFAC
+28 DO NUM
+29 ;
+30 ;Build Service Category array
+31 IF $LENGTH(PXRMSCAT)>0
FOR IC=1:1:$LENGTH(PXRMSCAT,",")
SET PXRMSCAT($PIECE(PXRMSCAT,",",IC))=""
+32 ;
+33 ;Add Descriptions for Reminders
+34 DO DES(.PXRMREM,"^PXD(811.9",4)
+35 ;Add Descriptions for Reminder Categories
+36 DO DES(.PXRMRCAT,"^PXRMD(811.7",4)
+37 ;Add Descriptions for Teams
+38 DO DES(.PXRMOTM,"^OR(100.21",3)
+39 ;Add Display Codes for Stops
+40 DO CODE(.PXRMCS,"^DIC(40.7",3)
+41 ;
+42 ;Sort Reminders into display order
+43 DO SORT(.PXRMREM,.ORDER)
+44 ;Sort Reminders categories into display order
+45 DO SORT(.PXRMRCAT,.ORDERC)
+46 ;
+47 ;Combine individual reminders and category reminders
+48 DO MERGE^PXRMXS1
+49 QUIT
+50 ;
+51 ;
+52 ;Extract INTernal and EXTernal format from ARRAY
+53 ;-----------------------------------------------
SUB(OUTPUT,SUB,VAR,ORD) ;
+1 KILL OUTPUT
+2 NEW IC,INT,EXT,SUB1,DISP
+3 SET SUB1=""
SET IC=0
+4 FOR
SET SUB1=$ORDER(ARRAY(SUB,SUB1))
if SUB1=""
QUIT
Begin DoDot:1
+5 SET INT=$PIECE($GET(ARRAY(SUB,SUB1,MREF(VAR),"I")),";")
+6 SET EXT=$GET(ARRAY(SUB,SUB1,MREF(VAR),"E"))
+7 SET IC=IC+1
+8 IF ORD=1
SET OUTPUT(IC)=INT_U_EXT
+9 IF ORD'=1
SET OUTPUT(IC)=EXT_U_INT
+10 IF (VAR'="REMINDER")&(VAR'="REMINDER CATEGORY")
QUIT
+11 ;Get display order
+12 SET DISP=$GET(ARRAY(SUB,SUB1,MREF("DISPLAY ORDER"),"I"))
+13 ;Store in PXRMREM for display
+14 SET OUTPUT(IC)=OUTPUT(IC)_U_DISP
+15 ;Put reminders with no sequence number last
+16 IF DISP=""
SET DISP=99
+17 ;Create order array for sorting entries later
+18 IF VAR="REMINDER"
SET ORDER(DISP,IC)=""
+19 IF VAR="REMINDER CATEGORY"
SET ORDERC(DISP,IC)=""
End DoDot:1
+20 QUIT
+21 ;
+22 ;Build array PXRMFACN and NFAC
+23 ;-----------------------------
NUM NEW IC,FACN,FACNAM
+1 KILL PXRMLOCN,PXRMCSN,PXRMCGRN,PXRMFACN
+2 SET IC=""
+3 FOR
SET IC=$ORDER(PXRMFAC(IC))
if IC=""
QUIT
Begin DoDot:1
+4 SET FACN=$PIECE(PXRMFAC(IC),U)
SET FACNAM=$PIECE(PXRMFAC(IC),U,2)
+5 SET PXRMFACN(FACN)=FACNAM_U_FACN
SET NFAC=IC
End DoDot:1
+6 ; Build Array PXRMLOCN and NHL
+7 NEW LOCN
+8 FOR
SET IC=$ORDER(PXRMLCHL(IC))
if IC=""
QUIT
Begin DoDot:1
+9 SET LOCN=$PIECE(PXRMLCHL(IC),U,2)
+10 SET PXRMLOCN(LOCN)=IC
SET NHL=IC
End DoDot:1
+11 ; Build Array PXRMCSN and NCS
+12 NEW CSN
+13 FOR
SET IC=$ORDER(PXRMCS(IC))
if IC=""
QUIT
Begin DoDot:1
+14 SET CSN=$PIECE(PXRMCS(IC),U,2)
+15 SET PXRMCSN(CSN)=IC
SET NCS=IC
End DoDot:1
+16 ; Build Array PXRMCGRN and NCGRP
+17 NEW GRPN
+18 FOR
SET IC=$ORDER(PXRMCGRP(IC))
if IC=""
QUIT
Begin DoDot:1
+19 SET GRPN=$PIECE(PXRMCGRP(IC),U,1)
+20 SET PXRMCGRN(GRPN)=IC
SET NCGRP=IC
End DoDot:1
+21 QUIT
+22 ;
+23 ;Add print name to OUTPUT array
+24 ;-------------------------------
DES(OUTPUT,GLOB,POSN) ;
+1 NEW IC,IEN,DES
+2 SET IC=""
+3 FOR
SET IC=$ORDER(OUTPUT(IC))
if IC=""
QUIT
Begin DoDot:1
+4 SET IEN=$PIECE(OUTPUT(IC),U,1)
+5 XECUTE "S DES=$P($G("_GLOB_",IEN,0)),U,3)"
+6 SET $PIECE(OUTPUT(IC),U,POSN)=DES
End DoDot:1
+7 QUIT
+8 ;
+9 ;Add stop code to OUTPUT array
+10 ;-------------------------------
CODE(OUTPUT,GLOB,POSN) ;
+1 NEW IC,IEN,CODE
+2 SET IC=""
+3 FOR
SET IC=$ORDER(OUTPUT(IC))
if IC=""
QUIT
Begin DoDot:1
+4 SET IEN=$PIECE(OUTPUT(IC),U,2)
+5 XECUTE "S CODE=$P($G("_GLOB_",IEN,0)),U,2)"
+6 SET $PIECE(OUTPUT(IC),U,POSN)=CODE
End DoDot:1
+7 QUIT
+8 ;
+9 ;Sort reminders into display order (allow for duplicates)
+10 ;--------------------------------------------------------
SORT(INPUT,ORDER) ;
+1 NEW IC,DISP,OUTPUT,IC1
+2 SET DISP=""
SET IC1=0
+3 FOR
SET DISP=$ORDER(ORDER(DISP))
if DISP=""
QUIT
Begin DoDot:1
+4 SET IC=""
+5 FOR
SET IC=$ORDER(ORDER(DISP,IC))
if IC=""
QUIT
Begin DoDot:2
+6 SET IC1=IC1+1
SET OUTPUT(IC1)=INPUT(IC)
End DoDot:2
End DoDot:1
+7 ; Move results back
+8 KILL INPUT
MERGE INPUT=OUTPUT
+9 QUIT
