PXRMORED ;SLC/AGP - Reminder Order Checks Editor ;10/17/2018
;;2.0;CLINICAL REMINDERS;**22,45**;Feb 04, 2005;Build 566
;
Q
;
ADD(INPUT,FILENUM) ;
;Add code is used when creating a new orderable item group
N DA,DIC,Y,DTOUT,DUOUT,DTYP,DLAYGO,NEW
S DIC=$S(FILENUM=801.1:"^PXD(801.1,",1:"^PXD(801,")
;Set the starting place for additions.
I INPUT="E" S DIC(0)="AELQ",DLAYGO=FILENUM
I INPUT="I" S DIC(0)="AEQ"
S DIC("A")=$S(FILENUM=801.1:"Select Reminder Order Check Rule: ",1:"Reminder Order Check Item Group: ")
D ^DIC
I $D(DUOUT)!($D(DTOUT))!($D(DUOUT)) Q
I Y=-1 K DIC Q
S NEW=+$P(Y,U,3)
I INPUT="I" D Q
.N BY,DC,DHD,FLD,FR,HTEXT,IENN,NOW,TO
.S FLDS="[PXRM ORDER CHECK ITEMS GROUP]"
.S HTEXT="REMINDER ORDER CHECK ITEMS GROUP INQUIRY"
.I FILENUM=801.1 D
..S FLDS="[PXRM ORDER CHECK RULE INQUIRY]"
..S HTEXT="REMINDER ORDER CHECK RULE INQUIRY"
.D SET^PXRMINQ(Y,HTEXT)
.;NAME OF PRINT TEMPLATE SHOULD BE CHANGED?
.D DISP^PXRMINQ(DIC,FLDS)
I INPUT="E" D EDIT(+Y,FILENUM,NEW)
Q
;
BUILD(FILENUM,REF,INPUT,ITEM,CNT,ALPHA,MATCH) ;
;build a list of orderable item group entries that contain ITEM
N ARRAY,IEN,NAME
K ^TMP($J,"PXRMORCL")
S CNT=0
S IEN=0 F S IEN=$O(^PXD(FILENUM,REF,ITEM,IEN)) Q:IEN'>0 D
.S NAME=$P(^PXD(FILENUM,IEN,0),U)
.S ARRAY(NAME)=IEN
I '$D(ARRAY) W !,"No matching "_$S(FILENUM=801.1:"order check rules",1:"order check items group")_" found." Q 0
;
;build output display text in alpha array this loop is used to build
;a format for the DIR call can use in the SELECT line tag
S NAME="" F S NAME=$O(ARRAY(NAME)) Q:NAME="" D
.S IEN=ARRAY(NAME)
.;
.;if use for inquiry build temp global for inquiry
.I INPUT="I" S ^TMP($J,"PXRMORCL",IEN)="" Q
.;
.S CNT=CNT+1,ALPHA(CNT)=$$RJ^XLFSTR(CNT,4," ")_" "_NAME
.S MATCH(CNT,IEN)=NAME
;
I INPUT="I" D
.N BY,DIC,DHD,FLDS,FR,GBL,HTEXT,L,PXRMROOT,TO
.S GBL=$S(FILENUM=801:"^PXD(801,",1:"^PXD(801.1,")
.S (DIC,PXRMROOT)=GBL
.S FLDS="[PXRM ORDER CHECK ITEMS GROUP]"
.S HTEXT="REMINDER ORDER CHECK ITEMS GROUP INQUIRY"
.I FILENUM=801.1 D
..S FLDS="[PXRM ORDER CHECK RULE INQUIRY]"
..S HTEXT="REMINDER ORDER CHECK RULE INQUIRY"
.S L=0,L(0)=1,BY=.01,BY(0)="^TMP($J,""PXRMORCL""",FR="",TO=""
.S DHD="@@"
.D EN1^DIP
K ^TMP($J,"PXRMORCL")
Q
;
DELTXT(IEN) ;
;delete the order check text called when the order check text
;is no longer valid for order check rule
N DA,DIK,TEMP
I '$D(^PXD(801.1,IEN,4)) Q
W !,"Deleting order check output text"
S DA(1)=IEN
S DIK="^PXD(801.1,"_DA(1)_",4,"
S DA=0 F S DA=$O(^PXD(801.1,DA(1),4,DA)) Q:DA'>0 S TEMP(DA)=""
S DA=0 F S DA=$O(TEMP(DA)) Q:DA'>0 D ^DIK
S ^PXD(801.1,IEN,5)=0
Q
;
EDIT(DA,FILENUM,NEW) ;
;PXRMNOIG is used in the template to control editing of fields for
;National Orderable Item Groups
N DIDEL
S DIDEL=FILENUM
I FILENUM=801 D SMANEDIT^PXRMOCG(DA,NEW) Q
I FILENUM=801.1 D SMANEDIT^PXRMOCR(DA,NEW) Q
Q
;
EN(INPUT,FILENUM) ;
EN1 ;
;inital editor and inquiry entry point. This controls which
;way to select an order check group to edit, inquiry, or to add a new
;one. Input="E" editing/adding an entry Input="I" doing an inquiry
N CNT,DIR,HTEXT,TAG,TYPE
S TYPE=$S(FILENUM=801.1:"Order Check Rule",1:"Order Check Items Group")
S CNT=0
S CNT=CNT+1,HTEXT(CNT)="\\Select 'N' to select an "_TYPE_" name."
I FILENUM=801 S CNT=CNT+1,HTEXT(CNT)="\\Select 'C' to select an "_TYPE_" by Drug Class"
I FILENUM=801 S CNT=CNT+1,HTEXT(CNT)="\\Select 'D' to select an "_TYPE_" by Drug"
I FILENUM=801 S CNT=CNT+1,HTEXT(CNT)="\\Select 'G' to select an "_TYPE_" by VA Generic"
I FILENUM=801 S CNT=CNT+1,HTEXT(CNT)="\\Select 'I' to select an "_TYPE_" by an Imaging Type"
I FILENUM=801 S CNT=CNT+1,HTEXT(CNT)="\\Select 'O' to select an "_TYPE_" by an Orderable Item"
I FILENUM=801 S CNT=CNT+1,HTEXT(CNT)="\\Select 'P' to select an "_TYPE_" by an VA Product"
I FILENUM=801 S CNT=CNT+1,HTEXT(CNT)="\\Select 'R' to select an "_TYPE_" by an Order Check Rule"
I FILENUM=801.1 S CNT=CNT+1,HTEXT(CNT)="\\Select 'R' to select an "_TYPE_" by a Reminder Definition."
I FILENUM=801.1 S CNT=CNT+1,HTEXT(CNT)="\\Select 'T' to select an "_TYPE_" by a Reminder Term."
S CNT=CNT+1,HTEXT(CNT)="\\Select Q to Quit"
S DIR(0)="SB^"
;
S CNT=1
S DIR("A")="Select Reminder "_TYPE_" by"
S DIR("A",CNT)=" N: "_$$UP^XLFSTR(TYPE)_" NAME"
I FILENUM=801 S CNT=CNT+1,DIR("A",CNT)=" C: VA DRUG CLASS"
I FILENUM=801 S CNT=CNT+1,DIR("A",CNT)=" D: DRUG"
I FILENUM=801 S CNT=CNT+1,DIR("A",CNT)=" G: VA GENERIC"
I FILENUM=801 S CNT=CNT+1,DIR("A",CNT)=" I: IMAGING TYPE"
I FILENUM=801 S CNT=CNT+1,DIR("A",CNT)=" O: ORDERABLE ITEM"
I FILENUM=801 S CNT=CNT+1,DIR("A",CNT)=" P: VA Product"
I FILENUM=801 S CNT=CNT+1,DIR("A",CNT)=" R: ORDER CHECK RULE"
I FILENUM=801.1 S CNT=CNT+1,DIR("A",CNT)=" R: REMINDER DEFINITION"
I FILENUM=801.1 S CNT=CNT+1,DIR("A",CNT)=" T: REMINDER TERM"
S CNT=CNT+1,DIR("A",CNT)=" Q: QUIT"
S CNT=CNT+1,DIR("A",CNT)=" "
I FILENUM=801 S DIR(0)=DIR(0)_"N:ORDER CHECK ITEM GROUP NAME;C:VA DRUG CLASS;D:DRUG;G:VA GENERIC;I:IMAGING TYPE;O:ORDERABLE ITEM;P:VA PRODUCT;R:ORDER CHECK RULE;Q:QUIT"
I FILENUM=801.1 S DIR(0)=DIR(0)_"N:ORDER CHECK RULE NAME;R:REMINDER DEFINITION;T:REMINDER TERM;Q:QUIT"
;
S DIR("B")="N"
S DIR("?")="Select one of the above option or '^' to quit. Enter ?? for detail help."
S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
W !,"Select Reminder "_TYPE_" by one of the following:",!!
D ^DIR
I Y="Q" Q
I Y[U Q
I $D(DTOUT) Q ;PXRM*2*22 RMS
D FIND(Y,INPUT,FILENUM)
G EN1
Q
;
FIND(TYPE,INPUT,FILENUM) ;
FIND1 ;
;general file look-up
N DIC,IEN,ROOT,SCREEN,Y
I TYPE="N" D ADD(INPUT,FILENUM) Q
I TYPE="C" S ROOT="^PS(50.605,"
I TYPE="D" S ROOT="^PSDRUG("
I TYPE="G" S ROOT="^PSNDF(50.6,"
I TYPE="I" S ROOT="^RA(79.2,"
I TYPE="O" S ROOT="^ORD(101.43,"
I TYPE="P" S ROOT="^PSNDF(50.68,"
I TYPE="T" S ROOT="^PXRMD(811.5,"
I TYPE="R" S ROOT=$S(FILENUM=801.1:"^PXD(811.9,",1:"^PXD(801.1,")
S DIC=ROOT
S DIC(0)="AEMOQ"
I ROOT="^PXD(811.9," S DIC("S")="I $P($G(^(100)),U,4)[""O"""
D ^DIC
I ($D(DTOUT))!($D(DUOUT))!(Y=-1) Q
I TYPE="N",+Y>0 D EDIT(+Y,801,0) Q
;TYPE matches the xref on file 801.
D SELECT(TYPE,INPUT,+Y,FILENUM)
K Y G FIND1
Q
;
HASDEF(DA) ;
I $P($G(^PXD(801.1,DA,3)),U)>0 Q 1
Q 0
;
HELP(TYPE) ;
N LC,NIN,NLINES,NOUT,TEXT,TEXTIN,TEXTOUT
I TYPE=1 D
.S TEXTIN(1)="Select 'Yes' to add all orderable items by a specific drug class."
.S TEXTIN(2)="After the orderable items are added the user will be able to do additional edits to the orderable item list."
.S TEXTIN(3)="\\Select 'No' if not adding medication orderable items,or not adding all orderable items for a drug class."
.S NIN=3
I '$D(TEXTIN) Q
D FORMAT^PXRMTEXT(1,75,NIN,.TEXTIN,.NLINES,.TEXT)
;write out the output
F LC=1:1:NLINES D
.S CNT=CNT+1 W !,TEXT(LC)
Q
;
INVALDIS(VALUE) ;
;is DISPLAY NAME field value in REMINDER ORDER CHECK RULES file invalid?
;1 = invalid display name, 0 = valid display name
I $G(PXRMINST)=1!($G(PXRMEXCH)=1) Q 0
N RETURN
S RETURN=1,VALUE=$G(VALUE)
I $L(VALUE)>=3,$L(VALUE)<=64 D
.I '$D(^PXD(801.1,"D",VALUE))!($D(^PXD(801.1,"D",VALUE))&($G(DIUTIL)="VERIFY FIELDS")) S RETURN=0
Q RETURN
;
NAT(DA,FILENUM) ;
;used by the input template to control editing of fields
I $G(DIUTIL)="VERIFY FIELDS" Q 1
I $G(PXRMINST)=1 Q 0
I $P($G(^PXD(FILENUM,DA,100)),U)="N" Q 1
Q 0
;
RULEUSEB(RULE) ;
N IEN,NAME
I '$D(^PXD(801,"R",RULE)) Q
W !,"Rule in use by:"
S IEN=0 F S IEN=$O(^PXD(801,"R",RULE,IEN)) Q:IEN'>0 D
.S NAME=$P($G(^PXD(801,IEN,0)),U) Q:NAME=""
.W !," "_NAME
Q
;
RULEIUSE(RULE) ;
I $D(^PXD(801,"R",RULE)) Q 0
Q 1
;
ITEMINQ ;
N DIEW,DIWF,DIWL,NAME,PAD,X
S DIWF="C80",DIWL=2
S NAME="",PAD=" "
F S NAME=$O(^PXD(801,D0,1.5,"OCIO",NAME)) Q:NAME="" D
.S X=PAD_NAME
.D ^DIWP
Q
;
RULEINQ(FILENUM) ;
;this entry point is used to build the RULE multiple output for the
;INQUIRY option
;
N DIEW,DIWF,DIWL,PAD,RIEN,RJC,NODE,NODE100,X
K ^TMP($J,"W")
I FILENUM=801 S RIEN=$G(^PXD(801,D0,3,D1,0))
I FILENUM=801.1 S RIEN=D0
D WPFORMAT(RIEN,1)
D WPFORMAT(RIEN,4)
S RJC=20,PAD=" "
S DIWF="C80",DIWL=2
S NODE=$G(^PXD(801.1,RIEN,0))
S X=$$RJ^XLFSTR("Rule Name:",RJC,PAD)
S X=X_" "_$P(NODE,U)
D ^DIWP
S X=$$RJ^XLFSTR("Display Name:",RJC,PAD)
S X=X_" "_$P(NODE,U,2)
D ^DIWP
S NODE100=$G(^PXD(801.1,RIEN,100))
S X=$$RJ^XLFSTR("Class:",RJC,PAD)
S X=X_" "_$S($P(NODE100,U)="L":"Local",$P(NODE100,U)="V":"VISN",1:"National")
D ^DIWP
S X=$$RJ^XLFSTR("Sponsor:",RJC,PAD)
I $P(NODE100,U,2)>0 S X=X_" "_$P($G(^PXRMD(811.6,$P(NODE100,U,2),0)),U)
D ^DIWP
S X=$$RJ^XLFSTR("Review Date:",RJC,PAD)
I $P(NODE100,U,3)>0 S X=X_" "_$$FMTE^XLFDT($P(NODE100,U,3))
D ^DIWP
S X=$$RJ^XLFSTR("Status:",RJC,PAD)
S X=X_" "_$S($P(NODE,U,3)="I":"Inactive",$P(NODE,U,3)="P":"Production",$P(NODE,U,3)="T":"Testing",$P(NODE,U,3)="N":"Notification")
D ^DIWP
S X=$$RJ^XLFSTR("Severity:",RJC,PAD)
S X=X_" "_$S($P(NODE,U,5)=1:"High",$P(NODE,U,5)=2:"Medium",1:"Low")
D ^DIWP
I $P($G(^PXD(801.1,RIEN,2)),U)'="" D Q
.S X=" " D ^DIWP
.S NODE=$G(^PXD(801.1,RIEN,2))
.S X=$$RJ^XLFSTR("Reminder Term:",RJC,PAD)
.S X=X_" "_$P($G(^PXRMD(811.5,$P(NODE,U),0)),U)
.D ^DIWP
.S X=$$RJ^XLFSTR("Reminder Term Status:",RJC,PAD)
.S X=X_" "_$S($P(NODE,U,2)=1:"TRUE",1:"FALSE")
.D ^DIWP
.D WPOUT(4,"Order Check Text",RJC,PAD)
.D WPOUT(1,"Rule Description",RJC,PAD)
S X=" " D ^DIWP
S NODE=$G(^PXD(801.1,RIEN,3)) I +$P(NODE,U)=0 G RULEINQX
S X=$$RJ^XLFSTR("Reminder Definition:",RJC,PAD)
S X=X_" "_$P($G(^PXD(811.9,$P(NODE,U),0)),U)
D ^DIWP
S X=$$RJ^XLFSTR("Definition Status:",RJC,PAD)
S X=X_" "_$S($P(NODE,U,2)="D":"Due",$P(NODE,U,2)="A":"Applicable",1:"N/A")
D ^DIWP
S X=$$RJ^XLFSTR("Output Text:",RJC,PAD)
S X=X_" "_$S($P(NODE,U,3)="O":"Order Check Text Only",$P(NODE,U,3)="D":"Definition Text Only",1:"Both Order Check and Definition Text")
D ^DIWP
D WPOUT(4,"Order Check Text",RJC,PAD)
D WPOUT(1,"Rule Description",RJC,PAD)
RULEINQX ;
K ^TMP($J,"W")
Q
;
RNXHELP ;Executable help for RULE NAME.
N TEXT
S TEXT(1)="Select an existing rule assigned to the order check items group to edit the rule."
D EN^DDIOL(.TEXT)
Q
;
SELECT(REF,INPUT,ITEM,FILENUM) ;
;if requested to find an orderable item group by Orderable, Definition,
;term this line tag is used
;
N ALPHA,CNT,DIROUT,DIRUT,DIR,DONE,MATCH,NAME
;I REF="C"!(REF="D")!(REF="G") D
;.S ITEM=ITEM_$S(REF="D":";PSDRUG(",REF="C":";PS(50.605,",REF="G":";PSNDF(50.6,",1:"")
;.S REF="P"
I REF="C"!(REF="D")!(REF="G")!(REF="I")!(REF="O")!(REF="P") D
.S ITEM=ITEM_$S(REF="D":";PSDRUG(",REF="C":";PS(50.605,",REF="G":";PSNDF(50.6,",REF="O":";ORD(101.43,",REF="I":";RA(79.2,",REF="P":";PSNDF(50.68,",1:"")
.S REF="O"
;build array by name of rules containing ITEM
D BUILD(FILENUM,REF,INPUT,ITEM,.CNT,.ALPHA,.MATCH)
;
I INPUT="I" Q
I CNT=0 Q
S DONE=0
;allow multiple edits of different orderable item groups
F Q:DONE D
.M DIR("A")=ALPHA
.S DIR("A")="Select a reminder orderable item group"
.S DIR(0)="NO^1:"_CNT
.W !!,"Select a reminder order check group from the following list:"
.D ^DIR
.I (Y="")!(Y["^") S DONE=1 Q
.I $D(DIROUT)!($D(DIRUT))!($D(DUOUT))!($D(DTOUT)) S DONE=1 Q
.S IEN=$O(MATCH(Y,"")) I IEN=0 Q
.D EDIT(IEN,FILENUM,0)
.;rebuild build array by name of rules containing ITEM
.D BUILD(REF,INPUT,ITEM,.CNT,.ALPHA,.MATCH)
Q
;
SNOCTL(DA) ;
;set the number of lines in the order check text multiple
N NUM,NOLC,PIPECNT
S (NUM,NOLC,PIPECNT)=0
F S NUM=$O(^PXD(801.1,DA,4,NUM)) Q:NUM'>0 D
.S PIPECNT=PIPECNT+$L(^PXD(801.1,DA,4,NUM,0),"|")-1
.S NOLC=NOLC+1
I (PIPECNT#2)=1 D TIUOBJW^PXRMFNFT("Order Check Text",PIPECNT)
I PIPECNT>0 S NOLC=NOLC_"T"
S ^PXD(801.1,DA,5)=NOLC
Q
;
;STATUS(Y) ;
;I $D(PXRMINST) Q 1
;I Y="N" Q 0
;Q 1
;
WPFORMAT(RIEN,SUB) ;
;use for inquiry, build word-processing fields to be used later
;because of DIWP API
;
N CNT,NLINES,NUM,TEXTIN,TEXTOUT,TITLE
I '$D(^PXD(801.1,RIEN,SUB)) Q
S CNT=0,NUM=0
F S CNT=$O(^PXD(801.1,RIEN,SUB,CNT)) Q:CNT'>0 D
.S NUM=NUM+1,TEXTIN(NUM)=$G(^PXD(801.1,RIEN,SUB,CNT,0))
D FORMAT^PXRMTEXT(22,74,NUM,.TEXTIN,.NLINES,.TEXTOUT)
S ^TMP($J,"W",SUB)=NLINES
F CNT=1:1:NLINES D
.S ^TMP($J,"W",SUB,CNT)=TEXTOUT(CNT)
Q
;
WPOUT(SUB,TITLE,RJC,PAD) ;
;print out word processing field text used by INQUIRY
I '$D(^TMP($J,"W",SUB)) Q
N IND,PADS,X
S PADS=" "
S X=$$RJ^XLFSTR(TITLE_":",RJC,PAD)
D ^DIWP
F IND=1:1:^TMP($J,"W",SUB) D
.S X=^TMP($J,"W",SUB,IND)
.D ^DIWP
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMORED 12804 printed Oct 16, 2024@17:47:46 Page 2
PXRMORED ;SLC/AGP - Reminder Order Checks Editor ;10/17/2018
+1 ;;2.0;CLINICAL REMINDERS;**22,45**;Feb 04, 2005;Build 566
+2 ;
+3 QUIT
+4 ;
ADD(INPUT,FILENUM) ;
+1 ;Add code is used when creating a new orderable item group
+2 NEW DA,DIC,Y,DTOUT,DUOUT,DTYP,DLAYGO,NEW
+3 SET DIC=$SELECT(FILENUM=801.1:"^PXD(801.1,",1:"^PXD(801,")
+4 ;Set the starting place for additions.
+5 IF INPUT="E"
SET DIC(0)="AELQ"
SET DLAYGO=FILENUM
+6 IF INPUT="I"
SET DIC(0)="AEQ"
+7 SET DIC("A")=$SELECT(FILENUM=801.1:"Select Reminder Order Check Rule: ",1:"Reminder Order Check Item Group: ")
+8 DO ^DIC
+9 IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+10 IF Y=-1
KILL DIC
QUIT
+11 SET NEW=+$PIECE(Y,U,3)
+12 IF INPUT="I"
Begin DoDot:1
+13 NEW BY,DC,DHD,FLD,FR,HTEXT,IENN,NOW,TO
+14 SET FLDS="[PXRM ORDER CHECK ITEMS GROUP]"
+15 SET HTEXT="REMINDER ORDER CHECK ITEMS GROUP INQUIRY"
+16 IF FILENUM=801.1
Begin DoDot:2
+17 SET FLDS="[PXRM ORDER CHECK RULE INQUIRY]"
+18 SET HTEXT="REMINDER ORDER CHECK RULE INQUIRY"
End DoDot:2
+19 DO SET^PXRMINQ(Y,HTEXT)
+20 ;NAME OF PRINT TEMPLATE SHOULD BE CHANGED?
+21 DO DISP^PXRMINQ(DIC,FLDS)
End DoDot:1
QUIT
+22 IF INPUT="E"
DO EDIT(+Y,FILENUM,NEW)
+23 QUIT
+24 ;
BUILD(FILENUM,REF,INPUT,ITEM,CNT,ALPHA,MATCH) ;
+1 ;build a list of orderable item group entries that contain ITEM
+2 NEW ARRAY,IEN,NAME
+3 KILL ^TMP($JOB,"PXRMORCL")
+4 SET CNT=0
+5 SET IEN=0
FOR
SET IEN=$ORDER(^PXD(FILENUM,REF,ITEM,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+6 SET NAME=$PIECE(^PXD(FILENUM,IEN,0),U)
+7 SET ARRAY(NAME)=IEN
End DoDot:1
+8 IF '$DATA(ARRAY)
WRITE !,"No matching "_$SELECT(FILENUM=801.1:"order check rules",1:"order check items group")_" found."
QUIT 0
+9 ;
+10 ;build output display text in alpha array this loop is used to build
+11 ;a format for the DIR call can use in the SELECT line tag
+12 SET NAME=""
FOR
SET NAME=$ORDER(ARRAY(NAME))
if NAME=""
QUIT
Begin DoDot:1
+13 SET IEN=ARRAY(NAME)
+14 ;
+15 ;if use for inquiry build temp global for inquiry
+16 IF INPUT="I"
SET ^TMP($JOB,"PXRMORCL",IEN)=""
QUIT
+17 ;
+18 SET CNT=CNT+1
SET ALPHA(CNT)=$$RJ^XLFSTR(CNT,4," ")_" "_NAME
+19 SET MATCH(CNT,IEN)=NAME
End DoDot:1
+20 ;
+21 IF INPUT="I"
Begin DoDot:1
+22 NEW BY,DIC,DHD,FLDS,FR,GBL,HTEXT,L,PXRMROOT,TO
+23 SET GBL=$SELECT(FILENUM=801:"^PXD(801,",1:"^PXD(801.1,")
+24 SET (DIC,PXRMROOT)=GBL
+25 SET FLDS="[PXRM ORDER CHECK ITEMS GROUP]"
+26 SET HTEXT="REMINDER ORDER CHECK ITEMS GROUP INQUIRY"
+27 IF FILENUM=801.1
Begin DoDot:2
+28 SET FLDS="[PXRM ORDER CHECK RULE INQUIRY]"
+29 SET HTEXT="REMINDER ORDER CHECK RULE INQUIRY"
End DoDot:2
+30 SET L=0
SET L(0)=1
SET BY=.01
SET BY(0)="^TMP($J,""PXRMORCL"""
SET FR=""
SET TO=""
+31 SET DHD="@@"
+32 DO EN1^DIP
End DoDot:1
+33 KILL ^TMP($JOB,"PXRMORCL")
+34 QUIT
+35 ;
DELTXT(IEN) ;
+1 ;delete the order check text called when the order check text
+2 ;is no longer valid for order check rule
+3 NEW DA,DIK,TEMP
+4 IF '$DATA(^PXD(801.1,IEN,4))
QUIT
+5 WRITE !,"Deleting order check output text"
+6 SET DA(1)=IEN
+7 SET DIK="^PXD(801.1,"_DA(1)_",4,"
+8 SET DA=0
FOR
SET DA=$ORDER(^PXD(801.1,DA(1),4,DA))
if DA'>0
QUIT
SET TEMP(DA)=""
+9 SET DA=0
FOR
SET DA=$ORDER(TEMP(DA))
if DA'>0
QUIT
DO ^DIK
+10 SET ^PXD(801.1,IEN,5)=0
+11 QUIT
+12 ;
EDIT(DA,FILENUM,NEW) ;
+1 ;PXRMNOIG is used in the template to control editing of fields for
+2 ;National Orderable Item Groups
+3 NEW DIDEL
+4 SET DIDEL=FILENUM
+5 IF FILENUM=801
DO SMANEDIT^PXRMOCG(DA,NEW)
QUIT
+6 IF FILENUM=801.1
DO SMANEDIT^PXRMOCR(DA,NEW)
QUIT
+7 QUIT
+8 ;
EN(INPUT,FILENUM) ;
EN1 ;
+1 ;inital editor and inquiry entry point. This controls which
+2 ;way to select an order check group to edit, inquiry, or to add a new
+3 ;one. Input="E" editing/adding an entry Input="I" doing an inquiry
+4 NEW CNT,DIR,HTEXT,TAG,TYPE
+5 SET TYPE=$SELECT(FILENUM=801.1:"Order Check Rule",1:"Order Check Items Group")
+6 SET CNT=0
+7 SET CNT=CNT+1
SET HTEXT(CNT)="\\Select 'N' to select an "_TYPE_" name."
+8 IF FILENUM=801
SET CNT=CNT+1
SET HTEXT(CNT)="\\Select 'C' to select an "_TYPE_" by Drug Class"
+9 IF FILENUM=801
SET CNT=CNT+1
SET HTEXT(CNT)="\\Select 'D' to select an "_TYPE_" by Drug"
+10 IF FILENUM=801
SET CNT=CNT+1
SET HTEXT(CNT)="\\Select 'G' to select an "_TYPE_" by VA Generic"
+11 IF FILENUM=801
SET CNT=CNT+1
SET HTEXT(CNT)="\\Select 'I' to select an "_TYPE_" by an Imaging Type"
+12 IF FILENUM=801
SET CNT=CNT+1
SET HTEXT(CNT)="\\Select 'O' to select an "_TYPE_" by an Orderable Item"
+13 IF FILENUM=801
SET CNT=CNT+1
SET HTEXT(CNT)="\\Select 'P' to select an "_TYPE_" by an VA Product"
+14 IF FILENUM=801
SET CNT=CNT+1
SET HTEXT(CNT)="\\Select 'R' to select an "_TYPE_" by an Order Check Rule"
+15 IF FILENUM=801.1
SET CNT=CNT+1
SET HTEXT(CNT)="\\Select 'R' to select an "_TYPE_" by a Reminder Definition."
+16 IF FILENUM=801.1
SET CNT=CNT+1
SET HTEXT(CNT)="\\Select 'T' to select an "_TYPE_" by a Reminder Term."
+17 SET CNT=CNT+1
SET HTEXT(CNT)="\\Select Q to Quit"
+18 SET DIR(0)="SB^"
+19 ;
+20 SET CNT=1
+21 SET DIR("A")="Select Reminder "_TYPE_" by"
+22 SET DIR("A",CNT)=" N: "_$$UP^XLFSTR(TYPE)_" NAME"
+23 IF FILENUM=801
SET CNT=CNT+1
SET DIR("A",CNT)=" C: VA DRUG CLASS"
+24 IF FILENUM=801
SET CNT=CNT+1
SET DIR("A",CNT)=" D: DRUG"
+25 IF FILENUM=801
SET CNT=CNT+1
SET DIR("A",CNT)=" G: VA GENERIC"
+26 IF FILENUM=801
SET CNT=CNT+1
SET DIR("A",CNT)=" I: IMAGING TYPE"
+27 IF FILENUM=801
SET CNT=CNT+1
SET DIR("A",CNT)=" O: ORDERABLE ITEM"
+28 IF FILENUM=801
SET CNT=CNT+1
SET DIR("A",CNT)=" P: VA Product"
+29 IF FILENUM=801
SET CNT=CNT+1
SET DIR("A",CNT)=" R: ORDER CHECK RULE"
+30 IF FILENUM=801.1
SET CNT=CNT+1
SET DIR("A",CNT)=" R: REMINDER DEFINITION"
+31 IF FILENUM=801.1
SET CNT=CNT+1
SET DIR("A",CNT)=" T: REMINDER TERM"
+32 SET CNT=CNT+1
SET DIR("A",CNT)=" Q: QUIT"
+33 SET CNT=CNT+1
SET DIR("A",CNT)=" "
+34 IF FILENUM=801
SET DIR(0)=DIR(0)_"N:ORDER CHECK ITEM GROUP NAME;C:VA DRUG CLASS;D:DRUG;G:VA GENERIC;I:IMAGING TYPE;O:ORDERABLE ITEM;P:VA PRODUCT;R:ORDER CHECK RULE;Q:QUIT"
+35 IF FILENUM=801.1
SET DIR(0)=DIR(0)_"N:ORDER CHECK RULE NAME;R:REMINDER DEFINITION;T:REMINDER TERM;Q:QUIT"
+36 ;
+37 SET DIR("B")="N"
+38 SET DIR("?")="Select one of the above option or '^' to quit. Enter ?? for detail help."
+39 SET DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
+40 WRITE !,"Select Reminder "_TYPE_" by one of the following:",!!
+41 DO ^DIR
+42 IF Y="Q"
QUIT
+43 IF Y[U
QUIT
+44 ;PXRM*2*22 RMS
IF $DATA(DTOUT)
QUIT
+45 DO FIND(Y,INPUT,FILENUM)
+46 GOTO EN1
+47 QUIT
+48 ;
FIND(TYPE,INPUT,FILENUM) ;
FIND1 ;
+1 ;general file look-up
+2 NEW DIC,IEN,ROOT,SCREEN,Y
+3 IF TYPE="N"
DO ADD(INPUT,FILENUM)
QUIT
+4 IF TYPE="C"
SET ROOT="^PS(50.605,"
+5 IF TYPE="D"
SET ROOT="^PSDRUG("
+6 IF TYPE="G"
SET ROOT="^PSNDF(50.6,"
+7 IF TYPE="I"
SET ROOT="^RA(79.2,"
+8 IF TYPE="O"
SET ROOT="^ORD(101.43,"
+9 IF TYPE="P"
SET ROOT="^PSNDF(50.68,"
+10 IF TYPE="T"
SET ROOT="^PXRMD(811.5,"
+11 IF TYPE="R"
SET ROOT=$SELECT(FILENUM=801.1:"^PXD(811.9,",1:"^PXD(801.1,")
+12 SET DIC=ROOT
+13 SET DIC(0)="AEMOQ"
+14 IF ROOT="^PXD(811.9,"
SET DIC("S")="I $P($G(^(100)),U,4)[""O"""
+15 DO ^DIC
+16 IF ($DATA(DTOUT))!($DATA(DUOUT))!(Y=-1)
QUIT
+17 IF TYPE="N"
IF +Y>0
DO EDIT(+Y,801,0)
QUIT
+18 ;TYPE matches the xref on file 801.
+19 DO SELECT(TYPE,INPUT,+Y,FILENUM)
+20 KILL Y
GOTO FIND1
+21 QUIT
+22 ;
HASDEF(DA) ;
+1 IF $PIECE($GET(^PXD(801.1,DA,3)),U)>0
QUIT 1
+2 QUIT 0
+3 ;
HELP(TYPE) ;
+1 NEW LC,NIN,NLINES,NOUT,TEXT,TEXTIN,TEXTOUT
+2 IF TYPE=1
Begin DoDot:1
+3 SET TEXTIN(1)="Select 'Yes' to add all orderable items by a specific drug class."
+4 SET TEXTIN(2)="After the orderable items are added the user will be able to do additional edits to the orderable item list."
+5 SET TEXTIN(3)="\\Select 'No' if not adding medication orderable items,or not adding all orderable items for a drug class."
+6 SET NIN=3
End DoDot:1
+7 IF '$DATA(TEXTIN)
QUIT
+8 DO FORMAT^PXRMTEXT(1,75,NIN,.TEXTIN,.NLINES,.TEXT)
+9 ;write out the output
+10 FOR LC=1:1:NLINES
Begin DoDot:1
+11 SET CNT=CNT+1
WRITE !,TEXT(LC)
End DoDot:1
+12 QUIT
+13 ;
INVALDIS(VALUE) ;
+1 ;is DISPLAY NAME field value in REMINDER ORDER CHECK RULES file invalid?
+2 ;1 = invalid display name, 0 = valid display name
+3 IF $GET(PXRMINST)=1!($GET(PXRMEXCH)=1)
QUIT 0
+4 NEW RETURN
+5 SET RETURN=1
SET VALUE=$GET(VALUE)
+6 IF $LENGTH(VALUE)>=3
IF $LENGTH(VALUE)<=64
Begin DoDot:1
+7 IF '$DATA(^PXD(801.1,"D",VALUE))!($DATA(^PXD(801.1,"D",VALUE))&($GET(DIUTIL)="VERIFY FIELDS"))
SET RETURN=0
End DoDot:1
+8 QUIT RETURN
+9 ;
NAT(DA,FILENUM) ;
+1 ;used by the input template to control editing of fields
+2 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT 1
+3 IF $GET(PXRMINST)=1
QUIT 0
+4 IF $PIECE($GET(^PXD(FILENUM,DA,100)),U)="N"
QUIT 1
+5 QUIT 0
+6 ;
RULEUSEB(RULE) ;
+1 NEW IEN,NAME
+2 IF '$DATA(^PXD(801,"R",RULE))
QUIT
+3 WRITE !,"Rule in use by:"
+4 SET IEN=0
FOR
SET IEN=$ORDER(^PXD(801,"R",RULE,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+5 SET NAME=$PIECE($GET(^PXD(801,IEN,0)),U)
if NAME=""
QUIT
+6 WRITE !," "_NAME
End DoDot:1
+7 QUIT
+8 ;
RULEIUSE(RULE) ;
+1 IF $DATA(^PXD(801,"R",RULE))
QUIT 0
+2 QUIT 1
+3 ;
ITEMINQ ;
+1 NEW DIEW,DIWF,DIWL,NAME,PAD,X
+2 SET DIWF="C80"
SET DIWL=2
+3 SET NAME=""
SET PAD=" "
+4 FOR
SET NAME=$ORDER(^PXD(801,D0,1.5,"OCIO",NAME))
if NAME=""
QUIT
Begin DoDot:1
+5 SET X=PAD_NAME
+6 DO ^DIWP
End DoDot:1
+7 QUIT
+8 ;
RULEINQ(FILENUM) ;
+1 ;this entry point is used to build the RULE multiple output for the
+2 ;INQUIRY option
+3 ;
+4 NEW DIEW,DIWF,DIWL,PAD,RIEN,RJC,NODE,NODE100,X
+5 KILL ^TMP($JOB,"W")
+6 IF FILENUM=801
SET RIEN=$GET(^PXD(801,D0,3,D1,0))
+7 IF FILENUM=801.1
SET RIEN=D0
+8 DO WPFORMAT(RIEN,1)
+9 DO WPFORMAT(RIEN,4)
+10 SET RJC=20
SET PAD=" "
+11 SET DIWF="C80"
SET DIWL=2
+12 SET NODE=$GET(^PXD(801.1,RIEN,0))
+13 SET X=$$RJ^XLFSTR("Rule Name:",RJC,PAD)
+14 SET X=X_" "_$PIECE(NODE,U)
+15 DO ^DIWP
+16 SET X=$$RJ^XLFSTR("Display Name:",RJC,PAD)
+17 SET X=X_" "_$PIECE(NODE,U,2)
+18 DO ^DIWP
+19 SET NODE100=$GET(^PXD(801.1,RIEN,100))
+20 SET X=$$RJ^XLFSTR("Class:",RJC,PAD)
+21 SET X=X_" "_$SELECT($PIECE(NODE100,U)="L":"Local",$PIECE(NODE100,U)="V":"VISN",1:"National")
+22 DO ^DIWP
+23 SET X=$$RJ^XLFSTR("Sponsor:",RJC,PAD)
+24 IF $PIECE(NODE100,U,2)>0
SET X=X_" "_$PIECE($GET(^PXRMD(811.6,$PIECE(NODE100,U,2),0)),U)
+25 DO ^DIWP
+26 SET X=$$RJ^XLFSTR("Review Date:",RJC,PAD)
+27 IF $PIECE(NODE100,U,3)>0
SET X=X_" "_$$FMTE^XLFDT($PIECE(NODE100,U,3))
+28 DO ^DIWP
+29 SET X=$$RJ^XLFSTR("Status:",RJC,PAD)
+30 SET X=X_" "_$SELECT($PIECE(NODE,U,3)="I":"Inactive",$PIECE(NODE,U,3)="P":"Production",$PIECE(NODE,U,3)="T":"Testing",$PIECE(NODE,U,3)="N":"Notification")
+31 DO ^DIWP
+32 SET X=$$RJ^XLFSTR("Severity:",RJC,PAD)
+33 SET X=X_" "_$SELECT($PIECE(NODE,U,5)=1:"High",$PIECE(NODE,U,5)=2:"Medium",1:"Low")
+34 DO ^DIWP
+35 IF $PIECE($GET(^PXD(801.1,RIEN,2)),U)'=""
Begin DoDot:1
+36 SET X=" "
DO ^DIWP
+37 SET NODE=$GET(^PXD(801.1,RIEN,2))
+38 SET X=$$RJ^XLFSTR("Reminder Term:",RJC,PAD)
+39 SET X=X_" "_$PIECE($GET(^PXRMD(811.5,$PIECE(NODE,U),0)),U)
+40 DO ^DIWP
+41 SET X=$$RJ^XLFSTR("Reminder Term Status:",RJC,PAD)
+42 SET X=X_" "_$SELECT($PIECE(NODE,U,2)=1:"TRUE",1:"FALSE")
+43 DO ^DIWP
+44 DO WPOUT(4,"Order Check Text",RJC,PAD)
+45 DO WPOUT(1,"Rule Description",RJC,PAD)
End DoDot:1
QUIT
+46 SET X=" "
DO ^DIWP
+47 SET NODE=$GET(^PXD(801.1,RIEN,3))
IF +$PIECE(NODE,U)=0
GOTO RULEINQX
+48 SET X=$$RJ^XLFSTR("Reminder Definition:",RJC,PAD)
+49 SET X=X_" "_$PIECE($GET(^PXD(811.9,$PIECE(NODE,U),0)),U)
+50 DO ^DIWP
+51 SET X=$$RJ^XLFSTR("Definition Status:",RJC,PAD)
+52 SET X=X_" "_$SELECT($PIECE(NODE,U,2)="D":"Due",$PIECE(NODE,U,2)="A":"Applicable",1:"N/A")
+53 DO ^DIWP
+54 SET X=$$RJ^XLFSTR("Output Text:",RJC,PAD)
+55 SET X=X_" "_$SELECT($PIECE(NODE,U,3)="O":"Order Check Text Only",$PIECE(NODE,U,3)="D":"Definition Text Only",1:"Both Order Check and Definition Text")
+56 DO ^DIWP
+57 DO WPOUT(4,"Order Check Text",RJC,PAD)
+58 DO WPOUT(1,"Rule Description",RJC,PAD)
RULEINQX ;
+1 KILL ^TMP($JOB,"W")
+2 QUIT
+3 ;
RNXHELP ;Executable help for RULE NAME.
+1 NEW TEXT
+2 SET TEXT(1)="Select an existing rule assigned to the order check items group to edit the rule."
+3 DO EN^DDIOL(.TEXT)
+4 QUIT
+5 ;
SELECT(REF,INPUT,ITEM,FILENUM) ;
+1 ;if requested to find an orderable item group by Orderable, Definition,
+2 ;term this line tag is used
+3 ;
+4 NEW ALPHA,CNT,DIROUT,DIRUT,DIR,DONE,MATCH,NAME
+5 ;I REF="C"!(REF="D")!(REF="G") D
+6 ;.S ITEM=ITEM_$S(REF="D":";PSDRUG(",REF="C":";PS(50.605,",REF="G":";PSNDF(50.6,",1:"")
+7 ;.S REF="P"
+8 IF REF="C"!(REF="D")!(REF="G")!(REF="I")!(REF="O")!(REF="P")
Begin DoDot:1
+9 SET ITEM=ITEM_$SELECT(REF="D":";PSDRUG(",REF="C":";PS(50.605,",REF="G":";PSNDF(50.6,",REF="O":";ORD(101.43,",REF="I":";RA(79.2,",REF="P":";PSNDF(50.68,",1:"")
+10 SET REF="O"
End DoDot:1
+11 ;build array by name of rules containing ITEM
+12 DO BUILD(FILENUM,REF,INPUT,ITEM,.CNT,.ALPHA,.MATCH)
+13 ;
+14 IF INPUT="I"
QUIT
+15 IF CNT=0
QUIT
+16 SET DONE=0
+17 ;allow multiple edits of different orderable item groups
+18 FOR
if DONE
QUIT
Begin DoDot:1
+19 MERGE DIR("A")=ALPHA
+20 SET DIR("A")="Select a reminder orderable item group"
+21 SET DIR(0)="NO^1:"_CNT
+22 WRITE !!,"Select a reminder order check group from the following list:"
+23 DO ^DIR
+24 IF (Y="")!(Y["^")
SET DONE=1
QUIT
+25 IF $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DUOUT))!($DATA(DTOUT))
SET DONE=1
QUIT
+26 SET IEN=$ORDER(MATCH(Y,""))
IF IEN=0
QUIT
+27 DO EDIT(IEN,FILENUM,0)
+28 ;rebuild build array by name of rules containing ITEM
+29 DO BUILD(REF,INPUT,ITEM,.CNT,.ALPHA,.MATCH)
End DoDot:1
+30 QUIT
+31 ;
SNOCTL(DA) ;
+1 ;set the number of lines in the order check text multiple
+2 NEW NUM,NOLC,PIPECNT
+3 SET (NUM,NOLC,PIPECNT)=0
+4 FOR
SET NUM=$ORDER(^PXD(801.1,DA,4,NUM))
if NUM'>0
QUIT
Begin DoDot:1
+5 SET PIPECNT=PIPECNT+$LENGTH(^PXD(801.1,DA,4,NUM,0),"|")-1
+6 SET NOLC=NOLC+1
End DoDot:1
+7 IF (PIPECNT#2)=1
DO TIUOBJW^PXRMFNFT("Order Check Text",PIPECNT)
+8 IF PIPECNT>0
SET NOLC=NOLC_"T"
+9 SET ^PXD(801.1,DA,5)=NOLC
+10 QUIT
+11 ;
+12 ;STATUS(Y) ;
+13 ;I $D(PXRMINST) Q 1
+14 ;I Y="N" Q 0
+15 ;Q 1
+16 ;
WPFORMAT(RIEN,SUB) ;
+1 ;use for inquiry, build word-processing fields to be used later
+2 ;because of DIWP API
+3 ;
+4 NEW CNT,NLINES,NUM,TEXTIN,TEXTOUT,TITLE
+5 IF '$DATA(^PXD(801.1,RIEN,SUB))
QUIT
+6 SET CNT=0
SET NUM=0
+7 FOR
SET CNT=$ORDER(^PXD(801.1,RIEN,SUB,CNT))
if CNT'>0
QUIT
Begin DoDot:1
+8 SET NUM=NUM+1
SET TEXTIN(NUM)=$GET(^PXD(801.1,RIEN,SUB,CNT,0))
End DoDot:1
+9 DO FORMAT^PXRMTEXT(22,74,NUM,.TEXTIN,.NLINES,.TEXTOUT)
+10 SET ^TMP($JOB,"W",SUB)=NLINES
+11 FOR CNT=1:1:NLINES
Begin DoDot:1
+12 SET ^TMP($JOB,"W",SUB,CNT)=TEXTOUT(CNT)
End DoDot:1
+13 QUIT
+14 ;
WPOUT(SUB,TITLE,RJC,PAD) ;
+1 ;print out word processing field text used by INQUIRY
+2 IF '$DATA(^TMP($JOB,"W",SUB))
QUIT
+3 NEW IND,PADS,X
+4 SET PADS=" "
+5 SET X=$$RJ^XLFSTR(TITLE_":",RJC,PAD)
+6 DO ^DIWP
+7 FOR IND=1:1:^TMP($JOB,"W",SUB)
Begin DoDot:1
+8 SET X=^TMP($JOB,"W",SUB,IND)
+9 DO ^DIWP
End DoDot:1
+10 QUIT
+11 ;
