PXRMORXR ; SLC/AGP - Reminder Order Checks XREF;01/27/2012
;;2.0;CLINICAL REMINDERS;**16,22**;Feb 04, 2005;Build 160
;
Q
;
;for the rules X(1)=RULE NAME, X(2)=ACTIVE FLAG, X(3)=TESTING FLAG
;
DELDRCL(IENS,OLD) ;
;This subroutine allows users to add delete orderable item that are
;THIS IS NO LONGER NEEDED AFTER PATCH 22 IS INSTALLED
I IENS(1)="" Q
I $G(PXRMDALL)=1 Q
I $G(DIUTIL)="VERIFY FIELDS" Q
I $G(OLD)="" Q
Q
;
;FORMAT OF XREF ^PXD(801,"AOIR",OI,TEST,GIEN,RULEIEN)=""
XREFCHK ;
N ACTIVE,CNT,GIEN,GNAME,OI,OINAME,OUTPUT,RIEN,RNAME,RULES,TEST,TEXTIN
;start from AOIR xref
S CNT=0,OI=0
F S OI=$O(^PXD(801,"AOIR",OI)) Q:OI'>0 D
.S OINAME=$P(^ORD(101.43,OI,0),U)
.I '$D(^PXD(801,"O",OI)) D Q
..K TEXTIN
..S TEXTIN(1)="Orderable item : "_OINAME_" does not exist in the Reminder Orderable Item Group file."
..D BUILDMSG(1,.TEXTIN,.CNT,.OUTPUT)
.S RIEN=0
.F S RIEN=$O(^PXD(801,"AOIR",OI,RIEN)) Q:RIEN'>0 D
..D CHKRULE(RIEN,.CNT,.OUTPUT)
..S GIEN=0 F S GIEN=$O(^PXD(801,"AOIR",OI,RIEN,GIEN)) Q:GIEN'>0 D
...I '$D(^PXD(801,GIEN)) D Q
....K TEXTIN
....S TEXTIN(1)="Reminder Orderable Item Group IEN "_GIEN_" does not exist in the file." Q
....D BUILDMSG(1,.TEXTIN,.CNT,.OUTPUT)
;
;from the ADRUGR cross-reference
N IEN,PHARMITM,TYPE
S TYPE="" F S TYPE=$O(^PXD(801,"ADRUGR",TYPE)) Q:TYPE="" D
.S IEN=0 F S IEN=$O(^PXD(801,"ADRUGR",TYPE,IEN)) Q:IEN'>0 D
..S PHARMITM(TYPE,IEN)=""
..S RIEN=0 F S RIEN=$O(^PXD(801,"ADRUGR",TYPE,IEN,RIEN)) Q:RIEN'>0 D
...D CHKRULE(RIEN,.CNT,.OUTPUT)
...S GIEN=0
...F S GIEN=$O(^PXD(801,"ADRUG",TYPE,IEN,RIEN,GIEN)) Q:GIEN'>0 D
....I '$D(^PXD(801,GIEN)) D Q
.....K TEXTIN
.....S TEXTIN(1)="Reminder Orderable Item Group IEN "_GIEN_" does not exist in the file." Q
.....D BUILDMSG(1,.TEXTIN,.CNT,.OUTPUT)
....D CHKGDR(GIEN,.PHARMITM,.CNT,.OUTPUT)
;
;check from file structure
S GIEN=0 F S GIEN=$O(^PXD(801,GIEN)) Q:GIEN'>0 D
.;build list of rules
.S RIEN=0 F S RIEN=$O(^PXD(801,GIEN,3,RIEN)) Q:RIEN'>0 S RULES(RIEN)=""
.;loop OI multiple for each OI
.S OI=0 F S OI=$O(^PXD(801,GIEN,2,"B",OI)) Q:OI'>0 D
..D CHKXFRF(GIEN,OI,"AOIR",.RULES)
;
;write out the output
I '$D(OUTPUT) W !,"No errors found" Q
S CNT=0 F S CNT=$O(OUTPUT(CNT)) Q:CNT'>0 W !,OUTPUT(CNT)
Q
;
BUILDMSG(NIN,TEXTIN,CNT,MESS) ;
N LINE,NOUT,TEXTOUT
D FORMAT^PXRMTEXT(1,75,NIN,.TEXTIN,.NOUT,.TEXTOUT)
S CNT=CNT+1,MESS(CNT)=""
F LINE=1:1:NOUT S CNT=CNT+1,MESS(CNT)=TEXTOUT(LINE)
Q
;
CHKXFRF(GIEN,ITEM,NODE,RULES) ;
N IEN,NAME,PIEN,TYPE
I ITEM[";" D I TYPE="" Q
.S TYPE=$S(ITEM["PSDRUG":"DR",ITEM["PSNDF(50.6":"DG",ITEM["PS(50.605":"DC",1:"")
.S PIEN=+ITEM
S IEN=0 F S IEN=$O(RULES(IEN)) Q:IEN'>0 D
.I NODE="AOIR" D Q
..I $D(^PXD(801,"AOIR",ITEM,RIEN,GIEN)) D
...K TEXTIN
...S TEXTIN(1)="ERROR IN AOIR CROSS-REFERENCE"
...S TEXTIN(2)="Rule ien: "_IEN_", OI ien: "_ITEM_", Group IEN: "_GIEN
...S TEXTIN(3)=" does not exist in the AOIR xref"
...D BUILDMSG(3,.TEXTIN,.CNT,.OUTPUT)
.I $D(^PXD(801,"ADRUGR",TYPE,PIEN,RIEN,GIEN)) Q
.K TEXTIN
.S TEXTIN(1)="ERROR IN ADRUGR CROSS-REFERENCE"
.S TEXTIN(2)="Rule ien: "_IEN_", Item ien: "_ITEM_", Group IEN: "_GIEN
.S TEXTIN(3)=" does not exist in the ADRUGR xref"
.D BUILDMSG(3,.TEXTIN,.CNT,.OUTPUT)
Q
;
CHKGDR(GIEN,PHARMITM,CNT,OUTPUT) ;
N GNAME,IEN,ITEM,TYPE
S GNAME=$P(^PXD(801,GIEN,0),U)
S TYPE="" F S TYPE=$O(PHARMITM(TYPE)) Q:TYPE="" D
.S IEN=0 F S IEN=$O(PHARMITM(TYPE,IEN)) Q:IEN'>0 D
..S ITEM=IEN_$S(TYPE="DR":";PSDRUG(",TYPE="DC":";PS(50.605",TYPE="DG":";PSNDF(50.6,",1:"")
..I ITEM'[";" Q
..I $D(^PXD(801,GIEN,1.5,"B",ITEM)) Q
..S TEXTIN(1)="Item: "_ITEM_" does not exist in the Reminder Orderable Item Group File entry."
..D BUILDMSG(1,.TEXTIN,.CNT,.OUTPUT)
Q
;
CHKRULE(RIEN,CNT,OUTPUT) ;
N NODE,RNAME,TEXTIN
I $D(^PXD(801.1,RIEN)) Q
S TEXTIN(1)="Rule Ien: "_RIEN_" does not exist in the Reminder Order Check Rule File entry."
D BUILDMSG(1,.TEXTIN,.CNT,.OUTPUT)
Q
;
DRUGKILL(DA,OLD) ;
N IEN,RIEN,TYPE
S TYPE=$S(OLD["PSDRUG":"DR",OLD["PSNDF(50.6":"DG",OLD["PS(50.605":"DC",1:"")
I TYPE="" Q
S IEN=0 F S IEN=$O(^PXD(801,DA(1),3,IEN)) Q:IEN'>0 D
.S RIEN=$P($G(^PXD(801,DA(1),3,IEN,0)),U) I +RIEN'>0 Q
.I $D(^PXD(801,"ADRUGR",TYPE,+OLD,RIEN,DA(1))) K ^PXD(801,"ADRUGR",TYPE,+OLD,RIEN,DA(1))
Q
;
DRUGSET(DA,NEW) ;
N RIEN,TYPE
;I '$D(^PXD(801,DA(1),3)) Q
S TYPE=$S(NEW["PSDRUG":"DR",NEW["PSNDF(50.6":"DG",NEW["PS(50.605":"DC",1:"")
I TYPE="" Q
S RIEN=0 F S RIEN=$O(^PXD(801,DA(1),3,"B",RIEN)) Q:RIEN'>0 D
.S ^PXD(801,"ADRUGR",TYPE,+NEW,RIEN,DA(1))=""
Q
;
OIKAOI(DA,OLD) ;
N IEN,RIEN
;I '$D(^PXD(801,DA(1),3)) Q
S IEN=0 F S IEN=$O(^PXD(801,DA(1),3,IEN)) Q:IEN'>0 D
.S RIEN=$P($G(^PXD(801,DA(1),3,IEN,0)),U) I +RIEN'>0 Q
.I $D(^PXD(801,"AOIR",OLD,RIEN,DA(1))) K ^PXD(801,"AOIR",OLD,RIEN,DA(1))
Q
;
OISAOI(DA,NEW) ;
N RIEN
;I '$D(^PXD(801,DA(1),3)) Q
S RIEN=0 F S RIEN=$O(^PXD(801,DA(1),3,"B",RIEN)) Q:RIEN'>0 D
.S ^PXD(801,"AOIR",NEW,RIEN,DA(1))=""
Q
;
RULEKAOI(DA,OLD) ;
;I OLD(1)=""!(OLD(2)="")!(OLD(3)="") Q
N DIEN,OI,TYPE
;kill OI index off
S OI=0 F S OI=$O(^PXD(801,DA(1),2,"B",OI)) Q:OI'>0 D
.I $D(^PXD(801,"AOIR",OI,OLD(1),DA(1))) K ^PXD(801,"AOIR",OI,OLD(1),DA(1))
; kill Drug Item Index off
S DIEN="" F S DIEN=$O(^PXD(801,DA(1),1.5,"B",DIEN)) Q:DIEN="" D
.S TYPE=$S(DIEN["PSDRUG":"DR",DIEN["PSNDF(50.6":"DG",DIEN["PS(50.605":"DC",1:"")
.I TYPE="" Q
.I $D(^PXD(801,"ADRUGR",TYPE,+DIEN,OLD(1),DA(1))) K ^PXD(801,"ADRUGR",TYPE,+DIEN,OLD(1),DA(1))
Q
;
RULESAOI(DA,NEW) ;
N DIEN,OI,TYPE
;set OI index
S OI=0 F S OI=$O(^PXD(801,DA(1),2,"B",OI)) Q:OI'>0 D
.S ^PXD(801,"AOIR",OI,NEW(1),DA(1))=""
;set Drug Item Index
S DIEN="" F S DIEN=$O(^PXD(801,DA(1),1.5,"B",DIEN)) Q:DIEN="" D
.S TYPE=$S(DIEN["PSDRUG":"DR",DIEN["PSNDF(50.6":"DG",DIEN["PS(50.605":"DC",1:"")
.I TYPE="" Q
.S ^PXD(801,"ADRUGR",TYPE,+DIEN,NEW(1),DA(1))=""
Q
;
TESTER ;
N CNT,DFN,DIC,DIROUT,DIRUT,DRUG,DTOUT,DUOUT,NAME,OI,ONAME,SEV,SUB,TEST
S DIC=2,DIC("A")="Select Patient: ",DIC(0)="AEQMZ" D ^DIC
I $D(DIROUT)!($D(DIRUT)) Q
I $D(DTOUT)!($D(DUOUT)) Q
S OI=0,DRUG=0
S DFN=+$P(Y,U)
W !,"Select an Orderable Item or press ENTER to select a Drug."
S DIC=101.43,DIC("A")="Select Orderable Item: ",DIC(0)="AEQMZ" D ^DIC
I $D(DIROUT)!($D(DIRUT)) Q
I $D(DTOUT)!($D(DUOUT)) Q
S OI=+$P(Y,U)
I +OI'>0 D
.S DIC=50,DIC("A")="Select Drug: ",DIC(0)="AEQMZ" D ^DIC
.I $D(DIROUT)!($D(DIRUT)) Q
.I $D(DTOUT)!($D(DUOUT)) Q
.S DRUG=+$P(Y,U)
I OI'>0,DRUG'>0 W !,"An Orderable Item or a Drug is required." Q
W !!
S SUB=$S(DRUG>0:DRUG,1:OI)
F TEST=0:1:1 D
.D ORDERCHK^PXRMORCH(DFN,OI,TEST,DRUG,1)
.I '$D(^TMP($J,SUB)) W !,"No "_$S(TEST=0:"Production Rules",1:"Testing Rules")_" found." Q
.W !,$S(TEST=0:"Production Rules:",1:"Testing Rules:")
.F SEV=3,2,1 D
..I '$D(^TMP($J,SUB,SEV)) W !,"No rules with a severity of "_$S(SEV=1:"High",SEV=2:"Medium",1:"Low")_" found." Q
..W !,$S(SEV=1:"High",SEV=2:"Medium",1:"Low")_" Severity Results:"
..S ONAME="",NAME=""
..F S NAME=$O(^TMP($J,SUB,SEV,NAME)) Q:NAME="" D
...I NAME'=ONAME S ONAME=NAME W !!,NAME
...S CNT=0 F S CNT=$O(^TMP($J,SUB,SEV,NAME,CNT)) Q:CNT'>0 D
....W !,^TMP($J,SUB,SEV,NAME,CNT)
Q
;
PXRMORXR ; SLC/AGP - Reminder Order Checks XREF;01/27/2012
+1 ;;2.0;CLINICAL REMINDERS;**16,22**;Feb 04, 2005;Build 160
+2 ;
+3 QUIT
+4 ;
+5 ;for the rules X(1)=RULE NAME, X(2)=ACTIVE FLAG, X(3)=TESTING FLAG
+6 ;
DELDRCL(IENS,OLD) ;
+1 ;This subroutine allows users to add delete orderable item that are
+2 ;THIS IS NO LONGER NEEDED AFTER PATCH 22 IS INSTALLED
+3 IF IENS(1)=""
QUIT
+4 IF $GET(PXRMDALL)=1
QUIT
+5 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+6 IF $GET(OLD)=""
QUIT
+7 QUIT
+8 ;
+9 ;FORMAT OF XREF ^PXD(801,"AOIR",OI,TEST,GIEN,RULEIEN)=""
XREFCHK ;
+1 NEW ACTIVE,CNT,GIEN,GNAME,OI,OINAME,OUTPUT,RIEN,RNAME,RULES,TEST,TEXTIN
+2 ;start from AOIR xref
+3 SET CNT=0
SET OI=0
+4 FOR
SET OI=$ORDER(^PXD(801,"AOIR",OI))
IF OI'>0
QUIT
Begin DoDot:1
+5 SET OINAME=$PIECE(^ORD(101.43,OI,0),U)
+6 IF '$DATA(^PXD(801,"O",OI))
Begin DoDot:2
+7 KILL TEXTIN
+8 SET TEXTIN(1)="Orderable item : "_OINAME_" does not exist in the Reminder Orderable Item Group file."
+9 DO BUILDMSG(1,.TEXTIN,.CNT,.OUTPUT)
End DoDot:2
QUIT
+10 SET RIEN=0
+11 FOR
SET RIEN=$ORDER(^PXD(801,"AOIR",OI,RIEN))
IF RIEN'>0
QUIT
Begin DoDot:2
+12 DO CHKRULE(RIEN,.CNT,.OUTPUT)
+13 SET GIEN=0
FOR
SET GIEN=$ORDER(^PXD(801,"AOIR",OI,RIEN,GIEN))
IF GIEN'>0
QUIT
Begin DoDot:3
+14 IF '$DATA(^PXD(801,GIEN))
Begin DoDot:4
+15 KILL TEXTIN
+16 SET TEXTIN(1)="Reminder Orderable Item Group IEN "_GIEN_" does not exist in the file."
QUIT
+17 DO BUILDMSG(1,.TEXTIN,.CNT,.OUTPUT)
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;
+19 ;from the ADRUGR cross-reference
+20 NEW IEN,PHARMITM,TYPE
+21 SET TYPE=""
FOR
SET TYPE=$ORDER(^PXD(801,"ADRUGR",TYPE))
IF TYPE=""
QUIT
Begin DoDot:1
+22 SET IEN=0
FOR
SET IEN=$ORDER(^PXD(801,"ADRUGR",TYPE,IEN))
IF IEN'>0
QUIT
Begin DoDot:2
+23 SET PHARMITM(TYPE,IEN)=""
+24 SET RIEN=0
FOR
SET RIEN=$ORDER(^PXD(801,"ADRUGR",TYPE,IEN,RIEN))
IF RIEN'>0
QUIT
Begin DoDot:3
+25 DO CHKRULE(RIEN,.CNT,.OUTPUT)
+26 SET GIEN=0
+27 FOR
SET GIEN=$ORDER(^PXD(801,"ADRUG",TYPE,IEN,RIEN,GIEN))
IF GIEN'>0
QUIT
Begin DoDot:4
+28 IF '$DATA(^PXD(801,GIEN))
Begin DoDot:5
+29 KILL TEXTIN
+30 SET TEXTIN(1)="Reminder Orderable Item Group IEN "_GIEN_" does not exist in the file."
QUIT
+31 DO BUILDMSG(1,.TEXTIN,.CNT,.OUTPUT)
End DoDot:5
QUIT
+32 DO CHKGDR(GIEN,.PHARMITM,.CNT,.OUTPUT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;
+34 ;check from file structure
+35 SET GIEN=0
FOR
SET GIEN=$ORDER(^PXD(801,GIEN))
IF GIEN'>0
QUIT
Begin DoDot:1
+36 ;build list of rules
+37 SET RIEN=0
FOR
SET RIEN=$ORDER(^PXD(801,GIEN,3,RIEN))
IF RIEN'>0
QUIT
SET RULES(RIEN)=""
+38 ;loop OI multiple for each OI
+39 SET OI=0
FOR
SET OI=$ORDER(^PXD(801,GIEN,2,"B",OI))
IF OI'>0
QUIT
Begin DoDot:2
+40 DO CHKXFRF(GIEN,OI,"AOIR",.RULES)
End DoDot:2
End DoDot:1
+41 ;
+42 ;write out the output
+43 IF '$DATA(OUTPUT)
WRITE !,"No errors found"
QUIT
+44 SET CNT=0
FOR
SET CNT=$ORDER(OUTPUT(CNT))
IF CNT'>0
QUIT
WRITE !,OUTPUT(CNT)
+45 QUIT
+46 ;
BUILDMSG(NIN,TEXTIN,CNT,MESS) ;
+1 NEW LINE,NOUT,TEXTOUT
+2 DO FORMAT^PXRMTEXT(1,75,NIN,.TEXTIN,.NOUT,.TEXTOUT)
+3 SET CNT=CNT+1
SET MESS(CNT)=""
+4 FOR LINE=1:1:NOUT
SET CNT=CNT+1
SET MESS(CNT)=TEXTOUT(LINE)
+5 QUIT
+6 ;
CHKXFRF(GIEN,ITEM,NODE,RULES) ;
+1 NEW IEN,NAME,PIEN,TYPE
+2 IF ITEM[";"
Begin DoDot:1
+3 SET TYPE=$SELECT(ITEM["PSDRUG":"DR",ITEM["PSNDF(50.6":"DG",ITEM["PS(50.605":"DC",1:"")
+4 SET PIEN=+ITEM
End DoDot:1
IF TYPE=""
QUIT
+5 SET IEN=0
FOR
SET IEN=$ORDER(RULES(IEN))
IF IEN'>0
QUIT
Begin DoDot:1
+6 IF NODE="AOIR"
Begin DoDot:2
+7 IF $DATA(^PXD(801,"AOIR",ITEM,RIEN,GIEN))
Begin DoDot:3
+8 KILL TEXTIN
+9 SET TEXTIN(1)="ERROR IN AOIR CROSS-REFERENCE"
+10 SET TEXTIN(2)="Rule ien: "_IEN_", OI ien: "_ITEM_", Group IEN: "_GIEN
+11 SET TEXTIN(3)=" does not exist in the AOIR xref"
+12 DO BUILDMSG(3,.TEXTIN,.CNT,.OUTPUT)
End DoDot:3
End DoDot:2
QUIT
+13 IF $DATA(^PXD(801,"ADRUGR",TYPE,PIEN,RIEN,GIEN))
QUIT
+14 KILL TEXTIN
+15 SET TEXTIN(1)="ERROR IN ADRUGR CROSS-REFERENCE"
+16 SET TEXTIN(2)="Rule ien: "_IEN_", Item ien: "_ITEM_", Group IEN: "_GIEN
+17 SET TEXTIN(3)=" does not exist in the ADRUGR xref"
+18 DO BUILDMSG(3,.TEXTIN,.CNT,.OUTPUT)
End DoDot:1
+19 QUIT
+20 ;
CHKGDR(GIEN,PHARMITM,CNT,OUTPUT) ;
+1 NEW GNAME,IEN,ITEM,TYPE
+2 SET GNAME=$PIECE(^PXD(801,GIEN,0),U)
+3 SET TYPE=""
FOR
SET TYPE=$ORDER(PHARMITM(TYPE))
IF TYPE=""
QUIT
Begin DoDot:1
+4 SET IEN=0
FOR
SET IEN=$ORDER(PHARMITM(TYPE,IEN))
IF IEN'>0
QUIT
Begin DoDot:2
+5 SET ITEM=IEN_$SELECT(TYPE="DR":";PSDRUG(",TYPE="DC":";PS(50.605",TYPE="DG":";PSNDF(50.6,",1:"")
+6 IF ITEM'[";"
QUIT
+7 IF $DATA(^PXD(801,GIEN,1.5,"B",ITEM))
QUIT
+8 SET TEXTIN(1)="Item: "_ITEM_" does not exist in the Reminder Orderable Item Group File entry."
+9 DO BUILDMSG(1,.TEXTIN,.CNT,.OUTPUT)
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
CHKRULE(RIEN,CNT,OUTPUT) ;
+1 NEW NODE,RNAME,TEXTIN
+2 IF $DATA(^PXD(801.1,RIEN))
QUIT
+3 SET TEXTIN(1)="Rule Ien: "_RIEN_" does not exist in the Reminder Order Check Rule File entry."
+4 DO BUILDMSG(1,.TEXTIN,.CNT,.OUTPUT)
+5 QUIT
+6 ;
DRUGKILL(DA,OLD) ;
+1 NEW IEN,RIEN,TYPE
+2 SET TYPE=$SELECT(OLD["PSDRUG":"DR",OLD["PSNDF(50.6":"DG",OLD["PS(50.605":"DC",1:"")
+3 IF TYPE=""
QUIT
+4 SET IEN=0
FOR
SET IEN=$ORDER(^PXD(801,DA(1),3,IEN))
IF IEN'>0
QUIT
Begin DoDot:1
+5 SET RIEN=$PIECE($GET(^PXD(801,DA(1),3,IEN,0)),U)
IF +RIEN'>0
QUIT
+6 IF $DATA(^PXD(801,"ADRUGR",TYPE,+OLD,RIEN,DA(1)))
KILL ^PXD(801,"ADRUGR",TYPE,+OLD,RIEN,DA(1))
End DoDot:1
+7 QUIT
+8 ;
DRUGSET(DA,NEW) ;
+1 NEW RIEN,TYPE
+2 ;I '$D(^PXD(801,DA(1),3)) Q
+3 SET TYPE=$SELECT(NEW["PSDRUG":"DR",NEW["PSNDF(50.6":"DG",NEW["PS(50.605":"DC",1:"")
+4 IF TYPE=""
QUIT
+5 SET RIEN=0
FOR
SET RIEN=$ORDER(^PXD(801,DA(1),3,"B",RIEN))
IF RIEN'>0
QUIT
Begin DoDot:1
+6 SET ^PXD(801,"ADRUGR",TYPE,+NEW,RIEN,DA(1))=""
End DoDot:1
+7 QUIT
+8 ;
OIKAOI(DA,OLD) ;
+1 NEW IEN,RIEN
+2 ;I '$D(^PXD(801,DA(1),3)) Q
+3 SET IEN=0
FOR
SET IEN=$ORDER(^PXD(801,DA(1),3,IEN))
IF IEN'>0
QUIT
Begin DoDot:1
+4 SET RIEN=$PIECE($GET(^PXD(801,DA(1),3,IEN,0)),U)
IF +RIEN'>0
QUIT
+5 IF $DATA(^PXD(801,"AOIR",OLD,RIEN,DA(1)))
KILL ^PXD(801,"AOIR",OLD,RIEN,DA(1))
End DoDot:1
+6 QUIT
+7 ;
OISAOI(DA,NEW) ;
+1 NEW RIEN
+2 ;I '$D(^PXD(801,DA(1),3)) Q
+3 SET RIEN=0
FOR
SET RIEN=$ORDER(^PXD(801,DA(1),3,"B",RIEN))
IF RIEN'>0
QUIT
Begin DoDot:1
+4 SET ^PXD(801,"AOIR",NEW,RIEN,DA(1))=""
End DoDot:1
+5 QUIT
+6 ;
RULEKAOI(DA,OLD) ;
+1 ;I OLD(1)=""!(OLD(2)="")!(OLD(3)="") Q
+2 NEW DIEN,OI,TYPE
+3 ;kill OI index off
+4 SET OI=0
FOR
SET OI=$ORDER(^PXD(801,DA(1),2,"B",OI))
IF OI'>0
QUIT
Begin DoDot:1
+5 IF $DATA(^PXD(801,"AOIR",OI,OLD(1),DA(1)))
KILL ^PXD(801,"AOIR",OI,OLD(1),DA(1))
End DoDot:1
+6 ; kill Drug Item Index off
+7 SET DIEN=""
FOR
SET DIEN=$ORDER(^PXD(801,DA(1),1.5,"B",DIEN))
IF DIEN=""
QUIT
Begin DoDot:1
+8 SET TYPE=$SELECT(DIEN["PSDRUG":"DR",DIEN["PSNDF(50.6":"DG",DIEN["PS(50.605":"DC",1:"")
+9 IF TYPE=""
QUIT
+10 IF $DATA(^PXD(801,"ADRUGR",TYPE,+DIEN,OLD(1),DA(1)))
KILL ^PXD(801,"ADRUGR",TYPE,+DIEN,OLD(1),DA(1))
End DoDot:1
+11 QUIT
+12 ;
RULESAOI(DA,NEW) ;
+1 NEW DIEN,OI,TYPE
+2 ;set OI index
+3 SET OI=0
FOR
SET OI=$ORDER(^PXD(801,DA(1),2,"B",OI))
IF OI'>0
QUIT
Begin DoDot:1
+4 SET ^PXD(801,"AOIR",OI,NEW(1),DA(1))=""
End DoDot:1
+5 ;set Drug Item Index
+6 SET DIEN=""
FOR
SET DIEN=$ORDER(^PXD(801,DA(1),1.5,"B",DIEN))
IF DIEN=""
QUIT
Begin DoDot:1
+7 SET TYPE=$SELECT(DIEN["PSDRUG":"DR",DIEN["PSNDF(50.6":"DG",DIEN["PS(50.605":"DC",1:"")
+8 IF TYPE=""
QUIT
+9 SET ^PXD(801,"ADRUGR",TYPE,+DIEN,NEW(1),DA(1))=""
End DoDot:1
+10 QUIT
+11 ;
TESTER ;
+1 NEW CNT,DFN,DIC,DIROUT,DIRUT,DRUG,DTOUT,DUOUT,NAME,OI,ONAME,SEV,SUB,TEST
+2 SET DIC=2
SET DIC("A")="Select Patient: "
SET DIC(0)="AEQMZ"
DO ^DIC
+3 IF $DATA(DIROUT)!($DATA(DIRUT))
QUIT
+4 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+5 SET OI=0
SET DRUG=0
+6 SET DFN=+$PIECE(Y,U)
+7 WRITE !,"Select an Orderable Item or press ENTER to select a Drug."
+8 SET DIC=101.43
SET DIC("A")="Select Orderable Item: "
SET DIC(0)="AEQMZ"
DO ^DIC
+9 IF $DATA(DIROUT)!($DATA(DIRUT))
QUIT
+10 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+11 SET OI=+$PIECE(Y,U)
+12 IF +OI'>0
Begin DoDot:1
+13 SET DIC=50
SET DIC("A")="Select Drug: "
SET DIC(0)="AEQMZ"
DO ^DIC
+14 IF $DATA(DIROUT)!($DATA(DIRUT))
QUIT
+15 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+16 SET DRUG=+$PIECE(Y,U)
End DoDot:1
+17 IF OI'>0
IF DRUG'>0
WRITE !,"An Orderable Item or a Drug is required."
QUIT
+18 WRITE !!
+19 SET SUB=$SELECT(DRUG>0:DRUG,1:OI)
+20 FOR TEST=0:1:1
Begin DoDot:1
+21 DO ORDERCHK^PXRMORCH(DFN,OI,TEST,DRUG,1)
+22 IF '$DATA(^TMP($JOB,SUB))
WRITE !,"No "_$SELECT(TEST=0:"Production Rules",1:"Testing Rules")_" found."
QUIT
+23 WRITE !,$SELECT(TEST=0:"Production Rules:",1:"Testing Rules:")
+24 FOR SEV=3,2,1
Begin DoDot:2
+25 IF '$DATA(^TMP($JOB,SUB,SEV))
WRITE !,"No rules with a severity of "_$SELECT(SEV=1:"High",SEV=2:"Medium",1:"Low")_" found."
QUIT
+26 WRITE !,$SELECT(SEV=1:"High",SEV=2:"Medium",1:"Low")_" Severity Results:"
+27 SET ONAME=""
SET NAME=""
+28 FOR
SET NAME=$ORDER(^TMP($JOB,SUB,SEV,NAME))
IF NAME=""
QUIT
Begin DoDot:3
+29 IF NAME'=ONAME
SET ONAME=NAME
WRITE !!,NAME
+30 SET CNT=0
FOR
SET CNT=$ORDER(^TMP($JOB,SUB,SEV,NAME,CNT))
IF CNT'>0
QUIT
Begin DoDot:4
+31 WRITE !,^TMP($JOB,SUB,SEV,NAME,CNT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
