PXRMCLST ;SLC/PJH - List Reminder Categories ;08/25/2011
;;2.0;CLINICAL REMINDERS;**18**;Feb 04, 2005;Build 152
;
;List all categories (for protocol PXRM SELECTION LIST)
;-------------------
ALL N BY,DC,DHD,DIC,FLDS,FR,L,LOGIC,NOW,TO,Y
S Y=1
D SET
S DIC="^PXRMD(811.7,"
S BY=".01"
S FR=""
S TO=""
S DHD="W ?0 D HED^PXRMCLST"
D DISP
Q
;
;DISPLAY (Display from FLDS array)
;-------
DISP S L=0,FLDS="[PXRM REMINDER CATEGORIES]"
D EN1^DIP
Q
;
;Build list of sub-categories
;----------------------------
DSP N ARRAY,IC,SEQ,TAB,TXT
;
; D0=IEN OF PARENT D1=NODE NUMBER IN 10 OF CHILD
;
S IC=0 D GETLST(D0,D1,0)
;Display list of sub-categories
S IC=0
F S IC=$O(ARRAY(IC)) Q:IC="" D
.S TAB=$P(ARRAY(IC),U),TXT=$P(ARRAY(IC),U,2)
.W !,?TAB,TXT
Q
;
;Get list of sub-categories
;--------------------------
GETLST(D0,D1,LEVEL) ;
N CHILD,DATA,NAME,PXRMIEN,PXRMCAT,SEQ,SUB,TEMP
;Determine if this subcategory has children
S DATA=$G(^PXRMD(811.7,D0,10,D1,0)) Q:DATA=""
S PXRMCAT=$P(DATA,U) Q:PXRMCAT=""
S NAME=$G(^PXRMD(811.7,PXRMCAT,0)) I NAME="" S NAME=PXRMCAT
S IC=IC+1,ARRAY(IC)=LEVEL_U_"Sub-category: "_NAME
;Increment tab
S LEVEL=LEVEL+5
;Don't allow > 4 levels
I LEVEL>20 S IC=IC+1,ARRAY(IC)=LEVEL_U_"Further levels" Q
;
;Sort Reminders from this category into display sequence
S SUB=0 K TEMP
F S SUB=$O(^PXRMD(811.7,PXRMCAT,2,SUB)) Q:SUB="" D
.S DATA=$G(^PXRMD(811.7,PXRMCAT,2,SUB,0)) Q:DATA=""
.S PXRMIEN=$P(DATA,U) Q:PXRMIEN=""
.S SEQ=$P(DATA,U,2)
.S DATA=$G(^PXD(811.9,PXRMIEN,0)) Q:DATA=""
.S NAME=$P(DATA,U) I NAME="" S NAME="Unknown"
.S TEMP(SEQ)=NAME
;
;Re-save reminders in output array for display
S SEQ=""
F S SEQ=$O(TEMP(SEQ)) Q:SEQ="" D
.S IC=IC+1
.S ARRAY(IC)=LEVEL_U_"Sequence: "_$J(SEQ,2)_" Reminder: "_TEMP(SEQ)
;
;Sort Sub-Categories for this category into display order
S SUB=0 K TEMP
F S SUB=$O(^PXRMD(811.7,PXRMCAT,10,SUB)) Q:SUB="" D
.S DATA=$G(^PXRMD(811.7,PXRMCAT,10,SUB,0)) Q:DATA=""
.S SEQ=$P(DATA,U,2),TEMP(SEQ)=SUB
;
;Process sub-sub categories in the same manner
S SEQ=""
F S SEQ=$O(TEMP(SEQ)) Q:SEQ="" D
.S SUB=TEMP(SEQ)
.D GETLST(PXRMCAT,SUB,LEVEL)
Q
;
;Display Header (see DHD variable)
;--------------
HED N TEMP,TEXTLEN,TEXTHED,TEXTUND
S TEXTHED="REMINDER CATEGORY LIST"
S TEXTUND=$TR($J("",IOM)," ","-")
S TEMP=NOW_" Page "_DC
S TEXTLEN=$L(TEMP)
W TEXTHED
W ?(IOM-TEXTLEN),TEMP
W !,TEXTUND,!!
Q
;
;Inquire/Print Option (for protocol PXRM GENERAL INQUIRE/PRINT)
;--------------------
INQ(Y) N BY,DC,DHD,DIC,FLDS,FR,L,LOGIC,NOW,TO
S DIC="^PXRMD(811.7,"
S DIC(0)="AEMQ"
D SET
D DISP
Q
;
;Input Transforms for edit option PXRM REMINDER CATEGORY EDIT #811.7
;-------------------------------------------------------------------
BADITEM(X,DA1) ;Subcategory
I X=DA1 Q 1
Q '$$PARENTOK(DA1,X)
;
KILLAC ;This only applies if deleting a sub-category
I '$D(^PXRMD(811.7,DA)) Q
;
N SUB,MAS
S MAS=""
;Get the parent categories for this sub sub-category, quit if none
F S MAS=$O(^PXRMD(811.7,"AC",DA,MAS)) Q:MAS="" D
.;Get sub category position in the parent, quit if none
.S SUB=$O(^PXRMD(811.7,"AC",DA,MAS,"")) Q:SUB=""
.;
.;Kill the sub category on the parent category
.N DIC,DIK,DA S DIK="^PXRMD(811.7,MAS,10,",DA(1)=MAS,DA=SUB D ^DIK
.;Cross reference on SUBCATEGORY field kills the AC index entry
Q
;
PARENTOK(PARENT,ITEM) ;Returns true if category is already in tree
N IDX,OK
S IDX=0,OK=1
F S IDX=$O(^PXRMD(811.7,"AC",PARENT,IDX)) Q:'IDX D Q:'OK
.I IDX=ITEM S OK=0 Q
.S OK=$$PARENTOK(IDX,ITEM)
Q OK
;
;Reminders for this category
;---------------------------
REM N ARRAY,DATA,IC,NAME,PXRMIEN,SEQ,TEMP
;
; D0=IEN OF CATEGORY
;
S SUB=0
;Sort Reminders from this category into display sequence
F S SUB=$O(^PXRMD(811.7,D0,2,SUB)) Q:SUB="" D
.S DATA=$G(^PXRMD(811.7,D0,2,SUB,0)) Q:DATA=""
.S PXRMIEN=$P(DATA,U) Q:PXRMIEN=""
.S SEQ=$P(DATA,U,2)
.S DATA=$G(^PXD(811.9,PXRMIEN,0)) Q:DATA=""
.S NAME=$P(DATA,U) I NAME="" S NAME="Unknown"
.S TEMP(SEQ_0)=NAME
;
I $O(TEMP(""))="" W ! Q
;
;Re-save reminders in output array for display
S SEQ="",IC=0
F S SEQ=$O(TEMP(SEQ)) Q:SEQ="" D
.S IC=IC+1
.S ARRAY(IC)="Sequence: "_$J(SEQ/10,2)_" Reminder: "_TEMP(SEQ)
;
S IC=0
F S IC=$O(ARRAY(IC)) Q:IC="" D
.W !,ARRAY(IC)
Q
;
SETAC Q
;
;Verify Reminder/Category display order is unique
;RECORD 2=Reminder 10=Sub-category
UNIQUE(X,DA1,DA,RECORD) ;
N SUB,DATA,SEQ,TEMP
S SUB=0
F S SUB=$O(^PXRMD(811.7,DA1,RECORD,SUB)) Q:'SUB D
.Q:SUB=DA
.S SEQ=$P($G(^PXRMD(811.7,DA1,RECORD,SUB,0)),U,2)
.I SEQ'="" S TEMP(SEQ)=""
I $D(TEMP(X)) D EN^DDIOL("Sequence number "_X_" already used") Q 0
Q 1
;
SET ;Setup all the variables
; Set Date for Header
S NOW=$$NOW^XLFDT
S NOW=$$FMTE^XLFDT(NOW,"1P")
;
;These variables need to be setup every time because DIP kills them.
S BY="NUMBER"
S (FR,TO)=+$P(Y,U,1)
S DHD="W ?0 D HED^PXRMCLST"
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMCLST 5095 printed Dec 13, 2024@01:43:14 Page 2
PXRMCLST ;SLC/PJH - List Reminder Categories ;08/25/2011
+1 ;;2.0;CLINICAL REMINDERS;**18**;Feb 04, 2005;Build 152
+2 ;
+3 ;List all categories (for protocol PXRM SELECTION LIST)
+4 ;-------------------
ALL NEW BY,DC,DHD,DIC,FLDS,FR,L,LOGIC,NOW,TO,Y
+1 SET Y=1
+2 DO SET
+3 SET DIC="^PXRMD(811.7,"
+4 SET BY=".01"
+5 SET FR=""
+6 SET TO=""
+7 SET DHD="W ?0 D HED^PXRMCLST"
+8 DO DISP
+9 QUIT
+10 ;
+11 ;DISPLAY (Display from FLDS array)
+12 ;-------
DISP SET L=0
SET FLDS="[PXRM REMINDER CATEGORIES]"
+1 DO EN1^DIP
+2 QUIT
+3 ;
+4 ;Build list of sub-categories
+5 ;----------------------------
DSP NEW ARRAY,IC,SEQ,TAB,TXT
+1 ;
+2 ; D0=IEN OF PARENT D1=NODE NUMBER IN 10 OF CHILD
+3 ;
+4 SET IC=0
DO GETLST(D0,D1,0)
+5 ;Display list of sub-categories
+6 SET IC=0
+7 FOR
SET IC=$ORDER(ARRAY(IC))
if IC=""
QUIT
Begin DoDot:1
+8 SET TAB=$PIECE(ARRAY(IC),U)
SET TXT=$PIECE(ARRAY(IC),U,2)
+9 WRITE !,?TAB,TXT
End DoDot:1
+10 QUIT
+11 ;
+12 ;Get list of sub-categories
+13 ;--------------------------
GETLST(D0,D1,LEVEL) ;
+1 NEW CHILD,DATA,NAME,PXRMIEN,PXRMCAT,SEQ,SUB,TEMP
+2 ;Determine if this subcategory has children
+3 SET DATA=$GET(^PXRMD(811.7,D0,10,D1,0))
if DATA=""
QUIT
+4 SET PXRMCAT=$PIECE(DATA,U)
if PXRMCAT=""
QUIT
+5 SET NAME=$GET(^PXRMD(811.7,PXRMCAT,0))
IF NAME=""
SET NAME=PXRMCAT
+6 SET IC=IC+1
SET ARRAY(IC)=LEVEL_U_"Sub-category: "_NAME
+7 ;Increment tab
+8 SET LEVEL=LEVEL+5
+9 ;Don't allow > 4 levels
+10 IF LEVEL>20
SET IC=IC+1
SET ARRAY(IC)=LEVEL_U_"Further levels"
QUIT
+11 ;
+12 ;Sort Reminders from this category into display sequence
+13 SET SUB=0
KILL TEMP
+14 FOR
SET SUB=$ORDER(^PXRMD(811.7,PXRMCAT,2,SUB))
if SUB=""
QUIT
Begin DoDot:1
+15 SET DATA=$GET(^PXRMD(811.7,PXRMCAT,2,SUB,0))
if DATA=""
QUIT
+16 SET PXRMIEN=$PIECE(DATA,U)
if PXRMIEN=""
QUIT
+17 SET SEQ=$PIECE(DATA,U,2)
+18 SET DATA=$GET(^PXD(811.9,PXRMIEN,0))
if DATA=""
QUIT
+19 SET NAME=$PIECE(DATA,U)
IF NAME=""
SET NAME="Unknown"
+20 SET TEMP(SEQ)=NAME
End DoDot:1
+21 ;
+22 ;Re-save reminders in output array for display
+23 SET SEQ=""
+24 FOR
SET SEQ=$ORDER(TEMP(SEQ))
if SEQ=""
QUIT
Begin DoDot:1
+25 SET IC=IC+1
+26 SET ARRAY(IC)=LEVEL_U_"Sequence: "_$JUSTIFY(SEQ,2)_" Reminder: "_TEMP(SEQ)
End DoDot:1
+27 ;
+28 ;Sort Sub-Categories for this category into display order
+29 SET SUB=0
KILL TEMP
+30 FOR
SET SUB=$ORDER(^PXRMD(811.7,PXRMCAT,10,SUB))
if SUB=""
QUIT
Begin DoDot:1
+31 SET DATA=$GET(^PXRMD(811.7,PXRMCAT,10,SUB,0))
if DATA=""
QUIT
+32 SET SEQ=$PIECE(DATA,U,2)
SET TEMP(SEQ)=SUB
End DoDot:1
+33 ;
+34 ;Process sub-sub categories in the same manner
+35 SET SEQ=""
+36 FOR
SET SEQ=$ORDER(TEMP(SEQ))
if SEQ=""
QUIT
Begin DoDot:1
+37 SET SUB=TEMP(SEQ)
+38 DO GETLST(PXRMCAT,SUB,LEVEL)
End DoDot:1
+39 QUIT
+40 ;
+41 ;Display Header (see DHD variable)
+42 ;--------------
HED NEW TEMP,TEXTLEN,TEXTHED,TEXTUND
+1 SET TEXTHED="REMINDER CATEGORY LIST"
+2 SET TEXTUND=$TRANSLATE($JUSTIFY("",IOM)," ","-")
+3 SET TEMP=NOW_" Page "_DC
+4 SET TEXTLEN=$LENGTH(TEMP)
+5 WRITE TEXTHED
+6 WRITE ?(IOM-TEXTLEN),TEMP
+7 WRITE !,TEXTUND,!!
+8 QUIT
+9 ;
+10 ;Inquire/Print Option (for protocol PXRM GENERAL INQUIRE/PRINT)
+11 ;--------------------
INQ(Y) NEW BY,DC,DHD,DIC,FLDS,FR,L,LOGIC,NOW,TO
+1 SET DIC="^PXRMD(811.7,"
+2 SET DIC(0)="AEMQ"
+3 DO SET
+4 DO DISP
+5 QUIT
+6 ;
+7 ;Input Transforms for edit option PXRM REMINDER CATEGORY EDIT #811.7
+8 ;-------------------------------------------------------------------
BADITEM(X,DA1) ;Subcategory
+1 IF X=DA1
QUIT 1
+2 QUIT '$$PARENTOK(DA1,X)
+3 ;
KILLAC ;This only applies if deleting a sub-category
+1 IF '$DATA(^PXRMD(811.7,DA))
QUIT
+2 ;
+3 NEW SUB,MAS
+4 SET MAS=""
+5 ;Get the parent categories for this sub sub-category, quit if none
+6 FOR
SET MAS=$ORDER(^PXRMD(811.7,"AC",DA,MAS))
if MAS=""
QUIT
Begin DoDot:1
+7 ;Get sub category position in the parent, quit if none
+8 SET SUB=$ORDER(^PXRMD(811.7,"AC",DA,MAS,""))
if SUB=""
QUIT
+9 ;
+10 ;Kill the sub category on the parent category
+11 NEW DIC,DIK,DA
SET DIK="^PXRMD(811.7,MAS,10,"
SET DA(1)=MAS
SET DA=SUB
DO ^DIK
+12 ;Cross reference on SUBCATEGORY field kills the AC index entry
End DoDot:1
+13 QUIT
+14 ;
PARENTOK(PARENT,ITEM) ;Returns true if category is already in tree
+1 NEW IDX,OK
+2 SET IDX=0
SET OK=1
+3 FOR
SET IDX=$ORDER(^PXRMD(811.7,"AC",PARENT,IDX))
if 'IDX
QUIT
Begin DoDot:1
+4 IF IDX=ITEM
SET OK=0
QUIT
+5 SET OK=$$PARENTOK(IDX,ITEM)
End DoDot:1
if 'OK
QUIT
+6 QUIT OK
+7 ;
+8 ;Reminders for this category
+9 ;---------------------------
REM NEW ARRAY,DATA,IC,NAME,PXRMIEN,SEQ,TEMP
+1 ;
+2 ; D0=IEN OF CATEGORY
+3 ;
+4 SET SUB=0
+5 ;Sort Reminders from this category into display sequence
+6 FOR
SET SUB=$ORDER(^PXRMD(811.7,D0,2,SUB))
if SUB=""
QUIT
Begin DoDot:1
+7 SET DATA=$GET(^PXRMD(811.7,D0,2,SUB,0))
if DATA=""
QUIT
+8 SET PXRMIEN=$PIECE(DATA,U)
if PXRMIEN=""
QUIT
+9 SET SEQ=$PIECE(DATA,U,2)
+10 SET DATA=$GET(^PXD(811.9,PXRMIEN,0))
if DATA=""
QUIT
+11 SET NAME=$PIECE(DATA,U)
IF NAME=""
SET NAME="Unknown"
+12 SET TEMP(SEQ_0)=NAME
End DoDot:1
+13 ;
+14 IF $ORDER(TEMP(""))=""
WRITE !
QUIT
+15 ;
+16 ;Re-save reminders in output array for display
+17 SET SEQ=""
SET IC=0
+18 FOR
SET SEQ=$ORDER(TEMP(SEQ))
if SEQ=""
QUIT
Begin DoDot:1
+19 SET IC=IC+1
+20 SET ARRAY(IC)="Sequence: "_$JUSTIFY(SEQ/10,2)_" Reminder: "_TEMP(SEQ)
End DoDot:1
+21 ;
+22 SET IC=0
+23 FOR
SET IC=$ORDER(ARRAY(IC))
if IC=""
QUIT
Begin DoDot:1
+24 WRITE !,ARRAY(IC)
End DoDot:1
+25 QUIT
+26 ;
SETAC QUIT
+1 ;
+2 ;Verify Reminder/Category display order is unique
+3 ;RECORD 2=Reminder 10=Sub-category
UNIQUE(X,DA1,DA,RECORD) ;
+1 NEW SUB,DATA,SEQ,TEMP
+2 SET SUB=0
+3 FOR
SET SUB=$ORDER(^PXRMD(811.7,DA1,RECORD,SUB))
if 'SUB
QUIT
Begin DoDot:1
+4 if SUB=DA
QUIT
+5 SET SEQ=$PIECE($GET(^PXRMD(811.7,DA1,RECORD,SUB,0)),U,2)
+6 IF SEQ'=""
SET TEMP(SEQ)=""
End DoDot:1
+7 IF $DATA(TEMP(X))
DO EN^DDIOL("Sequence number "_X_" already used")
QUIT 0
+8 QUIT 1
+9 ;
SET ;Setup all the variables
+1 ; Set Date for Header
+2 SET NOW=$$NOW^XLFDT
+3 SET NOW=$$FMTE^XLFDT(NOW,"1P")
+4 ;
+5 ;These variables need to be setup every time because DIP kills them.
+6 SET BY="NUMBER"
+7 SET (FR,TO)=+$PIECE(Y,U,1)
+8 SET DHD="W ?0 D HED^PXRMCLST"
+9 ;
+10 QUIT
