- 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 Feb 18, 2025@23:09:36 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