- 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 Feb 18, 2025@23:13:17 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 ;