PXRMSTA1 ; SLC/AGP - Routines for building status list. ;05/08/2014
;;2.0;CLINICAL REMINDERS;**4,6,26**;Feb 04, 2005;Build 404
;
;This routine and PXRMSTA2 allows users to select the
;approriate status for Orders, Medication, Taxonomy, Problem List,
;and Radiology Procedure findings items.
;
ADD(GBL,FILE,CSTATUS,TYPE,WILD,DA,UPDATE) ;
N ANS,STATUS,TERMIEN
;Find what types of finding are in the term
I TYPE["PXRMD(811.5," D
.S TERMIEN=$P($G(TYPE),";")
.S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 Q
.I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"")
I TYPE=0 Q
;Find out what is in the taxonomy
I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"))
I TYPE[";" S TYPE=$P($G(TYPE),";",2)
I TYPE="PXD(811.2," D G ADDEX
.I $G(TAXTYPE)="R"!($G(TAXTYPE)="B") D DATA^PXRMSTA2(FILE,.DA,"RAMIS(71,","",.STATUS)
;Handle drug finding items
I TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D G ADDEX
.D SRXTYL^PXRMRXTY(NODE,.RXTYPE)
.D DATA^PXRMSTA2(FILE,.DA,"DRUG",.RXTYPE,.STATUS)
;Radiology and orderable item finding item
D DATA^PXRMSTA2(FILE,.DA,TYPE,"",.STATUS)
ADDEX ;
I '$D(STATUS) S UPDATE=0 Q
S STAT="" F S STAT=$O(STATUS(STAT)) Q:STAT=""!(WILD)=1 D
.I STAT["*" S WILD=1 Q
.S CSTATUS(STAT)=""
I WILD=1 K CSTATUS S CSTATUS("*")=""
S UPDATE=1 D DISPLAY(GBL,UPDATE,.WILD,0)
Q
;
ADDDEL(ANS,GBL,FILE,TYPE,NODE,WILD,DA,UPDATE,DELALL) ;
I $G(ANS)="" S ANS=$$PROMPT("S^A:ADD STATUS;D:DELETE A STATUS;S:SAVE AND QUIT;Q:QUIT WITHOUT SAVING CHANGES")
I "ADDASQ"'[ANS Q
I ANS="A",WILD=1 D
.W !,"Wildcard is already on the status list all possible statuses will be evaluated."
.W !,"To add a specific status please remove the wildcard first."
.S UPDATE=0 H 1
I ANS="A",WILD=0 D ADD(GBL,FILE,.CSTATUS,TYPE,.WILD,.DA,.UPDATE)
I ANS="D" D DELETE(GBL,FILE,.CSTATUS,NODE,.WILD,.DA,.UPDATE,.DELALL)
I ANS="S" S UPDATE="S"
I ANS="Q" S UPDATE="Q"
I UPDATE'="S",UPDATE'="Q" S DELALL=0 D ADDDEL("",GBL,FILE,TYPE,NODE,.WILD,.DA,.UPDATE,.DELALL)
; only update the new record if the action is Save
I UPDATE="S" D UPDATE(FILE,.UPDATE,.CSTATUS,.DA,.DELALL)
Q
;
ASK(STR,HTEXT) ;
N DIR,HTEXT
I '$D(HTEXT) S HTEXT(1)="Enter 'Y' to continue editing the Status List or '^' to Quit"
S DIR(0)="YA0"
S DIR("A")=STR
S DIR("B")="N"
S DIR("?")="Select either 'Y' or 'N' or '^' to quit. Enter ?? for detail help."
S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
D ^DIR
Q Y
;
CLEAR(GBL,FILE,DA) ;
N IEN,NODE,DIK,TEMP
I FILE="D" S DIK="^PXD(811.9,"_DA(2)_",20,"_DA(1)_",5,"
I FILE="T" S DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5,"
S DA=0 F S DA=$O(@GBL@(DA(2),20,DA(1),5,DA)) Q:DA'>0 S TEMP(DA)=""
S DA=0 F S DA=$O(TEMP(DA)) Q:DA'>0 D ^DIK
Q
;
DEFAULT(GBL,TYPE,NODE,RFILE,DELETE,DA) ;
N ANS,FDA,FILE,IND,MSG,STATUS,TERMIEN
S FILE=""
I TYPE["PXRMD(811.5," D
.S TERMIEN=$P($G(TYPE),";")
.S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 S STATUS="" Q
.I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"")
I TYPE=0 Q
I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"))
I TYPE[";" S TYPE=$P($G(TYPE),";",2)
I TYPE="PXD(811.2," D
.I $G(TAXTYPE)="R"!($G(TAXTYPE)="B") S FILE=70
I FILE="",TYPE="ORD(101.43," S FILE=100
I FILE="",TYPE="RAMIS(71," S FILE=70
I FILE="",TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D
.N DSTATUS,NAME,STATUSI,STATUSN,STATUSO,RXTYPE
.D SRXTYL^PXRMRXTY(NODE,.RXTYPE)
.I $D(RXTYPE("O")) D DEFAULT^PXRMSTAT(52,.STATUSO) D
..F IND=1:1:STATUSO(0) S DSTATUS(STATUSO(IND))=""
.I $D(RXTYPE("I")) D DEFAULT^PXRMSTAT(55,.STATUSI) D
..F IND=1:1:STATUSI(0) S DSTATUS(STATUSI(IND))=""
.I $D(RXTYPE("N")) D DEFAULT^PXRMSTAT("55NVA",.STATUSN) D
..F IND=1:1:STATUSN(0) S DSTATUS(STATUSN(IND))=""
.S NAME="",IND=0 F S NAME=$O(DSTATUS(NAME)) Q:NAME="" D
..S IND=IND+1 S STATUS(IND)=NAME
.S STATUS(0)=IND
I '$D(STATUS) D DEFAULT^PXRMSTAT(FILE,.STATUS)
F IND=1:1:STATUS(0) Q:$D(MSG)>0 D
.I DELETE=1 S CSTATUS(STATUS(IND))="" Q
.I $D(@GBL@(DA(2),20,DA(1),5,"B",STATUS(IND))) Q
.I RFILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND)
.I RFILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND)
.D UPDATE^DIE("","FDA","","MSG")
I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2
Q
;
DELETE(GBL,FILE,CSTATUS,NODE,WILD,DA,UPDATE,DELALL) ;
N ANS,CNT,DIK,NUM,NAME,DIR,TMP,TMPARR,Y
S CNT=0,NAME="" F S NAME=$O(CSTATUS(NAME)) Q:NAME="" D
.S CNT=CNT+1 S TMPARR(CNT)=CNT_" - "_NAME,TMP(CNT)=NAME
S DIR(0)="LO^1:"_CNT_""
M DIR("A")=TMPARR
S DIR("A")="Select which status to be deleted"
;S DIR("?")=HELP
D ^DIR
I $D(DTOUT)!($D(DUOUT))!($G(Y)="") Q
S CNT=0 F X=1:1:$L(Y(0)) D
.I $E(Y(0),X)="," S CNT=CNT+1,NUM=$P(Y(0),",",CNT) S NAME=TMP(NUM) K CSTATUS(NAME) I NAME["*" S WILD=0
S UPDATE=1
I FILE="T",$D(CSTATUS)'>0 S DELALL=1
D DISPLAY(GBL,UPDATE,.WILD,DELALL)
Q
;
DISPLAY(GBL,UPDATE,WILD,DELALL) ;
;Display statuses defined in the 5 node or display statuses if CStatus
;array has been loaded
N NAME
S NAME=""
I ((UPDATE=1)&(DELALL=1))!(($D(CSTATUS)'>0)&(UPDATE=0)&(GBL["811.5")&('$D(@GBL@(DA(2),20,DA(1),5)))) W !!,"No statuses defined for this finding item" W ! Q
W !!,"Statuses already defined for this finding item:"
I $D(CSTATUS)'>0,UPDATE=0 D
.F S NAME=$O(@GBL@(DA(2),20,DA(1),5,"B",NAME)) Q:NAME="" D
..I NAME["*" S WILD=1
..W !,NAME S CSTATUS(NAME)=$O(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME",""))
I UPDATE=1 F S NAME=$O(CSTATUS(NAME)) Q:NAME="" W !,NAME I NAME["*" S WILD=1
W !
Q
;
PROMPT(STR) ;
N DIR,HTEXT
S HTEXT(1)="Select 'A' to add a status to the current status list.\\Select 'D' to"
S HTEXT(2)="delete a status from the list.\\Select 'S' to save your changes and quit. "
S HTEXT(3)="\\Select 'Q' to quit without saving your changes."
S DIR(0)=STR
S DIR("B")="S"
S DIR("?")="Select one of the above option or '^' to quit. Enter ?? for detail help."
S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
D ^DIR
I $G(Y)="" S Y=U
Q Y
;
STATUS(DA,FILE) ;
N ANS,DELSTS,DELALL,GBL,NODE,PXRMRX,STATUS,STS,TAXIEN,TERMIEN,TAXTYPE,TTYPE,TYPE
N RXTYPE,TAXNODE,TERMTYPE,Y
N CSTATUS,UPDATE,HTEXT,OSTAUS,WILD
S DA(2)=DA(1),DA(1)=DA,DA="",UPDATE=0,DELALL=0
I FILE="D" S GBL="^PXD(811.9)"
I FILE="T" S GBL="^PXRMD(811.5)"
S NODE=$G(@GBL@(DA(2),20,DA(1),0))
S TYPE=$P($G(@GBL@(DA(2),20,DA(1),0)),U)
S WILD=0
;Check for current defined statuses if none set the default values
I FILE="D",$P($G(@GBL@(DA(2),20,DA(1),5,0)),U,4)'>0 D DEFAULT(GBL,TYPE,NODE,FILE,0,.DA)
;Display the current status
D DISPLAY(GBL,UPDATE,.WILD,DELALL)
;Do inital prompt
D ADDDEL($G(ANS),GBL,FILE,TYPE,NODE,WILD,.DA,.UPDATE,.DELALL)
Q
;
TAXNODE(TAXIEN) ;Determine if the taxonomy is searching Problem List and/or
;CPT codes which can be Radiology Procedures.
N PL,RAD,RESULT
S (PL,RAD,RESULT)=0
I (^PXD(811.2,TAXIEN,"APDS",71,"NNODES")>0),($D(^PXD(811.2,TAXIEN,20,"AE","CPT"))) S RAD=1
I ^PXD(811.2,TAXIEN,"APDS",9000011,"NNODES")>0 S PL=1
I RAD=1,PL=1 S RESULT="B"
I RAD=1,PL=0 S RESULT="R"
I RAD=0,PL=1 S RESULT="P"
Q RESULT
;
TAXTYPE(TERMIEN,HELP) ;Determine the Rx type of the term and the type of
;taxonomy
N ARRAY,BOTH,CNT,IEN,TAXNODE,RAD,PL,RESULT,TYPE
S (BOTH,PL,RAD,RESULT)=0
S IEN=0 F S IEN=$O(^PXRMD(811.5,TERMIEN,20,IEN)) Q:+IEN'>0 D
.S TAXNODE=$G(^PXRMD(811.5,TERMIEN,20,IEN,0))
.S ARRAY($P($P($G(TAXNODE),U),";"))=""
I $D(ARRAY)>0 S IEN=0 F S IEN=$O(ARRAY(IEN)) Q:IEN'>0 D
.S TYPE=$$TAXNODE(IEN)
.I TYPE="R" S RAD=1
.I TYPE="P" S PL=1
.I TYPE="B" S BOTH=1
I RAD=1,PL=1 S RESULT="B" Q
I RAD=1,PL=0,BOTH=0 S RESULT="R"
I RAD=0,PL=1,BOTH=0 S RESULT="P"
Q RESULT
;
TERMSTAT(TIEN) ;
N CNT,FIEN,NODE
S (CNT,FIEN)=0
S TYPE=0 F S FIEN=$O(^PXRMD(811.5,TIEN,20,FIEN)) Q:+FIEN=0!(CNT=1) D
. S NODE=$G(^PXRMD(811.5,TIEN,20,FIEN,0)),TYPE=$P(NODE,U),CNT=CNT+1
Q TYPE
;
UPDATE(FILE,UPDATE,CSTATUS,DA,DELALL) ;
N FDA,MSG,NAME
I UPDATE="S" S UPDATE=1
I UPDATE=0,$D(CSTATUS) G EXIT
D CLEAR(GBL,FILE,.DA)
I $D(CSTATUS)'>0 S UPDATE=0,DELALL=0 G EXIT
I $D(CSTATUS)'>0 S UPDATE=1,DELALL=1 G EXIT
S NAME="" F S NAME=$O(CSTATUS(NAME)) Q:NAME=""!($D(MSG)>0) D
.I FILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME
.I FILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME
.D UPDATE^DIE("","FDA","","MSG")
I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2
EXIT ;
Q
;
WARN ;
;If the whole entry is being deleted don't give the warning.
I $G(PXRMDEFD) Q
I $G(PXRMTMD) Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
N TEXT
S TEXT(1)=""
S TEXT(2)="Since you changed the value of Rx Type, you should review the status list"
S TEXT(3)="for the finding to make sure it is still appropriate."
S TEXT(4)=""
D EN^DDIOL(.TEXT)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMSTA1 8809 printed Sep 23, 2025@19:25:14 Page 2
PXRMSTA1 ; SLC/AGP - Routines for building status list. ;05/08/2014
+1 ;;2.0;CLINICAL REMINDERS;**4,6,26**;Feb 04, 2005;Build 404
+2 ;
+3 ;This routine and PXRMSTA2 allows users to select the
+4 ;approriate status for Orders, Medication, Taxonomy, Problem List,
+5 ;and Radiology Procedure findings items.
+6 ;
ADD(GBL,FILE,CSTATUS,TYPE,WILD,DA,UPDATE) ;
+1 NEW ANS,STATUS,TERMIEN
+2 ;Find what types of finding are in the term
+3 IF TYPE["PXRMD(811.5,"
Begin DoDot:1
+4 SET TERMIEN=$PIECE($GET(TYPE),";")
+5 SET TYPE=$$TERMSTAT(TERMIEN)
IF TYPE=0
QUIT
+6 IF TYPE["PXD"
SET TAXTYPE=$$TAXTYPE(TERMIEN,"")
End DoDot:1
+7 IF TYPE=0
QUIT
+8 ;Find out what is in the taxonomy
+9 IF TYPE["PXD(811.2,"
IF $GET(TAXTYPE)=""
SET TAXTYPE=$$TAXNODE($PIECE(TYPE,";"))
+10 IF TYPE[";"
SET TYPE=$PIECE($GET(TYPE),";",2)
+11 IF TYPE="PXD(811.2,"
Begin DoDot:1
+12 IF $GET(TAXTYPE)="R"!($GET(TAXTYPE)="B")
DO DATA^PXRMSTA2(FILE,.DA,"RAMIS(71,","",.STATUS)
End DoDot:1
GOTO ADDEX
+13 ;Handle drug finding items
+14 IF TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF")
Begin DoDot:1
+15 DO SRXTYL^PXRMRXTY(NODE,.RXTYPE)
+16 DO DATA^PXRMSTA2(FILE,.DA,"DRUG",.RXTYPE,.STATUS)
End DoDot:1
GOTO ADDEX
+17 ;Radiology and orderable item finding item
+18 DO DATA^PXRMSTA2(FILE,.DA,TYPE,"",.STATUS)
ADDEX ;
+1 IF '$DATA(STATUS)
SET UPDATE=0
QUIT
+2 SET STAT=""
FOR
SET STAT=$ORDER(STATUS(STAT))
if STAT=""!(WILD)=1
QUIT
Begin DoDot:1
+3 IF STAT["*"
SET WILD=1
QUIT
+4 SET CSTATUS(STAT)=""
End DoDot:1
+5 IF WILD=1
KILL CSTATUS
SET CSTATUS("*")=""
+6 SET UPDATE=1
DO DISPLAY(GBL,UPDATE,.WILD,0)
+7 QUIT
+8 ;
ADDDEL(ANS,GBL,FILE,TYPE,NODE,WILD,DA,UPDATE,DELALL) ;
+1 IF $GET(ANS)=""
SET ANS=$$PROMPT("S^A:ADD STATUS;D:DELETE A STATUS;S:SAVE AND QUIT;Q:QUIT WITHOUT SAVING CHANGES")
+2 IF "ADDASQ"'[ANS
QUIT
+3 IF ANS="A"
IF WILD=1
Begin DoDot:1
+4 WRITE !,"Wildcard is already on the status list all possible statuses will be evaluated."
+5 WRITE !,"To add a specific status please remove the wildcard first."
+6 SET UPDATE=0
HANG 1
End DoDot:1
+7 IF ANS="A"
IF WILD=0
DO ADD(GBL,FILE,.CSTATUS,TYPE,.WILD,.DA,.UPDATE)
+8 IF ANS="D"
DO DELETE(GBL,FILE,.CSTATUS,NODE,.WILD,.DA,.UPDATE,.DELALL)
+9 IF ANS="S"
SET UPDATE="S"
+10 IF ANS="Q"
SET UPDATE="Q"
+11 IF UPDATE'="S"
IF UPDATE'="Q"
SET DELALL=0
DO ADDDEL("",GBL,FILE,TYPE,NODE,.WILD,.DA,.UPDATE,.DELALL)
+12 ; only update the new record if the action is Save
+13 IF UPDATE="S"
DO UPDATE(FILE,.UPDATE,.CSTATUS,.DA,.DELALL)
+14 QUIT
+15 ;
ASK(STR,HTEXT) ;
+1 NEW DIR,HTEXT
+2 IF '$DATA(HTEXT)
SET HTEXT(1)="Enter 'Y' to continue editing the Status List or '^' to Quit"
+3 SET DIR(0)="YA0"
+4 SET DIR("A")=STR
+5 SET DIR("B")="N"
+6 SET DIR("?")="Select either 'Y' or 'N' or '^' to quit. Enter ?? for detail help."
+7 SET DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
+8 DO ^DIR
+9 QUIT Y
+10 ;
CLEAR(GBL,FILE,DA) ;
+1 NEW IEN,NODE,DIK,TEMP
+2 IF FILE="D"
SET DIK="^PXD(811.9,"_DA(2)_",20,"_DA(1)_",5,"
+3 IF FILE="T"
SET DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5,"
+4 SET DA=0
FOR
SET DA=$ORDER(@GBL@(DA(2),20,DA(1),5,DA))
if DA'>0
QUIT
SET TEMP(DA)=""
+5 SET DA=0
FOR
SET DA=$ORDER(TEMP(DA))
if DA'>0
QUIT
DO ^DIK
+6 QUIT
+7 ;
DEFAULT(GBL,TYPE,NODE,RFILE,DELETE,DA) ;
+1 NEW ANS,FDA,FILE,IND,MSG,STATUS,TERMIEN
+2 SET FILE=""
+3 IF TYPE["PXRMD(811.5,"
Begin DoDot:1
+4 SET TERMIEN=$PIECE($GET(TYPE),";")
+5 SET TYPE=$$TERMSTAT(TERMIEN)
IF TYPE=0
SET STATUS=""
QUIT
+6 IF TYPE["PXD"
SET TAXTYPE=$$TAXTYPE(TERMIEN,"")
End DoDot:1
+7 IF TYPE=0
QUIT
+8 IF TYPE["PXD(811.2,"
IF $GET(TAXTYPE)=""
SET TAXTYPE=$$TAXNODE($PIECE(TYPE,";"))
+9 IF TYPE[";"
SET TYPE=$PIECE($GET(TYPE),";",2)
+10 IF TYPE="PXD(811.2,"
Begin DoDot:1
+11 IF $GET(TAXTYPE)="R"!($GET(TAXTYPE)="B")
SET FILE=70
End DoDot:1
+12 IF FILE=""
IF TYPE="ORD(101.43,"
SET FILE=100
+13 IF FILE=""
IF TYPE="RAMIS(71,"
SET FILE=70
+14 IF FILE=""
IF TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF")
Begin DoDot:1
+15 NEW DSTATUS,NAME,STATUSI,STATUSN,STATUSO,RXTYPE
+16 DO SRXTYL^PXRMRXTY(NODE,.RXTYPE)
+17 IF $DATA(RXTYPE("O"))
DO DEFAULT^PXRMSTAT(52,.STATUSO)
Begin DoDot:2
+18 FOR IND=1:1:STATUSO(0)
SET DSTATUS(STATUSO(IND))=""
End DoDot:2
+19 IF $DATA(RXTYPE("I"))
DO DEFAULT^PXRMSTAT(55,.STATUSI)
Begin DoDot:2
+20 FOR IND=1:1:STATUSI(0)
SET DSTATUS(STATUSI(IND))=""
End DoDot:2
+21 IF $DATA(RXTYPE("N"))
DO DEFAULT^PXRMSTAT("55NVA",.STATUSN)
Begin DoDot:2
+22 FOR IND=1:1:STATUSN(0)
SET DSTATUS(STATUSN(IND))=""
End DoDot:2
+23 SET NAME=""
SET IND=0
FOR
SET NAME=$ORDER(DSTATUS(NAME))
if NAME=""
QUIT
Begin DoDot:2
+24 SET IND=IND+1
SET STATUS(IND)=NAME
End DoDot:2
+25 SET STATUS(0)=IND
End DoDot:1
+26 IF '$DATA(STATUS)
DO DEFAULT^PXRMSTAT(FILE,.STATUS)
+27 FOR IND=1:1:STATUS(0)
if $DATA(MSG)>0
QUIT
Begin DoDot:1
+28 IF DELETE=1
SET CSTATUS(STATUS(IND))=""
QUIT
+29 IF $DATA(@GBL@(DA(2),20,DA(1),5,"B",STATUS(IND)))
QUIT
+30 IF RFILE="D"
SET FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND)
+31 IF RFILE="T"
SET FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND)
+32 DO UPDATE^DIE("","FDA","","MSG")
End DoDot:1
+33 IF $DATA(MSG)>0
DO AWRITE^PXRMUTIL("MSG")
HANG 2
+34 QUIT
+35 ;
DELETE(GBL,FILE,CSTATUS,NODE,WILD,DA,UPDATE,DELALL) ;
+1 NEW ANS,CNT,DIK,NUM,NAME,DIR,TMP,TMPARR,Y
+2 SET CNT=0
SET NAME=""
FOR
SET NAME=$ORDER(CSTATUS(NAME))
if NAME=""
QUIT
Begin DoDot:1
+3 SET CNT=CNT+1
SET TMPARR(CNT)=CNT_" - "_NAME
SET TMP(CNT)=NAME
End DoDot:1
+4 SET DIR(0)="LO^1:"_CNT_""
+5 MERGE DIR("A")=TMPARR
+6 SET DIR("A")="Select which status to be deleted"
+7 ;S DIR("?")=HELP
+8 DO ^DIR
+9 IF $DATA(DTOUT)!($DATA(DUOUT))!($GET(Y)="")
QUIT
+10 SET CNT=0
FOR X=1:1:$LENGTH(Y(0))
Begin DoDot:1
+11 IF $EXTRACT(Y(0),X)=","
SET CNT=CNT+1
SET NUM=$PIECE(Y(0),",",CNT)
SET NAME=TMP(NUM)
KILL CSTATUS(NAME)
IF NAME["*"
SET WILD=0
End DoDot:1
+12 SET UPDATE=1
+13 IF FILE="T"
IF $DATA(CSTATUS)'>0
SET DELALL=1
+14 DO DISPLAY(GBL,UPDATE,.WILD,DELALL)
+15 QUIT
+16 ;
DISPLAY(GBL,UPDATE,WILD,DELALL) ;
+1 ;Display statuses defined in the 5 node or display statuses if CStatus
+2 ;array has been loaded
+3 NEW NAME
+4 SET NAME=""
+5 IF ((UPDATE=1)&(DELALL=1))!(($DATA(CSTATUS)'>0)&(UPDATE=0)&(GBL["811.5")&('$DATA(@GBL@(DA(2),20,DA(1),5))))
WRITE !!,"No statuses defined for this finding item"
WRITE !
QUIT
+6 WRITE !!,"Statuses already defined for this finding item:"
+7 IF $DATA(CSTATUS)'>0
IF UPDATE=0
Begin DoDot:1
+8 FOR
SET NAME=$ORDER(@GBL@(DA(2),20,DA(1),5,"B",NAME))
if NAME=""
QUIT
Begin DoDot:2
+9 IF NAME["*"
SET WILD=1
+10 WRITE !,NAME
SET CSTATUS(NAME)=$ORDER(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME",""))
End DoDot:2
End DoDot:1
+11 IF UPDATE=1
FOR
SET NAME=$ORDER(CSTATUS(NAME))
if NAME=""
QUIT
WRITE !,NAME
IF NAME["*"
SET WILD=1
+12 WRITE !
+13 QUIT
+14 ;
PROMPT(STR) ;
+1 NEW DIR,HTEXT
+2 SET HTEXT(1)="Select 'A' to add a status to the current status list.\\Select 'D' to"
+3 SET HTEXT(2)="delete a status from the list.\\Select 'S' to save your changes and quit. "
+4 SET HTEXT(3)="\\Select 'Q' to quit without saving your changes."
+5 SET DIR(0)=STR
+6 SET DIR("B")="S"
+7 SET DIR("?")="Select one of the above option or '^' to quit. Enter ?? for detail help."
+8 SET DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)"
+9 DO ^DIR
+10 IF $GET(Y)=""
SET Y=U
+11 QUIT Y
+12 ;
STATUS(DA,FILE) ;
+1 NEW ANS,DELSTS,DELALL,GBL,NODE,PXRMRX,STATUS,STS,TAXIEN,TERMIEN,TAXTYPE,TTYPE,TYPE
+2 NEW RXTYPE,TAXNODE,TERMTYPE,Y
+3 NEW CSTATUS,UPDATE,HTEXT,OSTAUS,WILD
+4 SET DA(2)=DA(1)
SET DA(1)=DA
SET DA=""
SET UPDATE=0
SET DELALL=0
+5 IF FILE="D"
SET GBL="^PXD(811.9)"
+6 IF FILE="T"
SET GBL="^PXRMD(811.5)"
+7 SET NODE=$GET(@GBL@(DA(2),20,DA(1),0))
+8 SET TYPE=$PIECE($GET(@GBL@(DA(2),20,DA(1),0)),U)
+9 SET WILD=0
+10 ;Check for current defined statuses if none set the default values
+11 IF FILE="D"
IF $PIECE($GET(@GBL@(DA(2),20,DA(1),5,0)),U,4)'>0
DO DEFAULT(GBL,TYPE,NODE,FILE,0,.DA)
+12 ;Display the current status
+13 DO DISPLAY(GBL,UPDATE,.WILD,DELALL)
+14 ;Do inital prompt
+15 DO ADDDEL($GET(ANS),GBL,FILE,TYPE,NODE,WILD,.DA,.UPDATE,.DELALL)
+16 QUIT
+17 ;
TAXNODE(TAXIEN) ;Determine if the taxonomy is searching Problem List and/or
+1 ;CPT codes which can be Radiology Procedures.
+2 NEW PL,RAD,RESULT
+3 SET (PL,RAD,RESULT)=0
+4 IF (^PXD(811.2,TAXIEN,"APDS",71,"NNODES")>0)
IF ($DATA(^PXD(811.2,TAXIEN,20,"AE","CPT")))
SET RAD=1
+5 IF ^PXD(811.2,TAXIEN,"APDS",9000011,"NNODES")>0
SET PL=1
+6 IF RAD=1
IF PL=1
SET RESULT="B"
+7 IF RAD=1
IF PL=0
SET RESULT="R"
+8 IF RAD=0
IF PL=1
SET RESULT="P"
+9 QUIT RESULT
+10 ;
TAXTYPE(TERMIEN,HELP) ;Determine the Rx type of the term and the type of
+1 ;taxonomy
+2 NEW ARRAY,BOTH,CNT,IEN,TAXNODE,RAD,PL,RESULT,TYPE
+3 SET (BOTH,PL,RAD,RESULT)=0
+4 SET IEN=0
FOR
SET IEN=$ORDER(^PXRMD(811.5,TERMIEN,20,IEN))
if +IEN'>0
QUIT
Begin DoDot:1
+5 SET TAXNODE=$GET(^PXRMD(811.5,TERMIEN,20,IEN,0))
+6 SET ARRAY($PIECE($PIECE($GET(TAXNODE),U),";"))=""
End DoDot:1
+7 IF $DATA(ARRAY)>0
SET IEN=0
FOR
SET IEN=$ORDER(ARRAY(IEN))
if IEN'>0
QUIT
Begin DoDot:1
+8 SET TYPE=$$TAXNODE(IEN)
+9 IF TYPE="R"
SET RAD=1
+10 IF TYPE="P"
SET PL=1
+11 IF TYPE="B"
SET BOTH=1
End DoDot:1
+12 IF RAD=1
IF PL=1
SET RESULT="B"
QUIT
+13 IF RAD=1
IF PL=0
IF BOTH=0
SET RESULT="R"
+14 IF RAD=0
IF PL=1
IF BOTH=0
SET RESULT="P"
+15 QUIT RESULT
+16 ;
TERMSTAT(TIEN) ;
+1 NEW CNT,FIEN,NODE
+2 SET (CNT,FIEN)=0
+3 SET TYPE=0
FOR
SET FIEN=$ORDER(^PXRMD(811.5,TIEN,20,FIEN))
if +FIEN=0!(CNT=1)
QUIT
Begin DoDot:1
+4 SET NODE=$GET(^PXRMD(811.5,TIEN,20,FIEN,0))
SET TYPE=$PIECE(NODE,U)
SET CNT=CNT+1
End DoDot:1
+5 QUIT TYPE
+6 ;
UPDATE(FILE,UPDATE,CSTATUS,DA,DELALL) ;
+1 NEW FDA,MSG,NAME
+2 IF UPDATE="S"
SET UPDATE=1
+3 IF UPDATE=0
IF $DATA(CSTATUS)
GOTO EXIT
+4 DO CLEAR(GBL,FILE,.DA)
+5 IF $DATA(CSTATUS)'>0
SET UPDATE=0
SET DELALL=0
GOTO EXIT
+6 IF $DATA(CSTATUS)'>0
SET UPDATE=1
SET DELALL=1
GOTO EXIT
+7 SET NAME=""
FOR
SET NAME=$ORDER(CSTATUS(NAME))
if NAME=""!($DATA(MSG)>0)
QUIT
Begin DoDot:1
+8 IF FILE="D"
SET FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME
+9 IF FILE="T"
SET FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME
+10 DO UPDATE^DIE("","FDA","","MSG")
End DoDot:1
+11 IF $DATA(MSG)>0
DO AWRITE^PXRMUTIL("MSG")
HANG 2
EXIT ;
+1 QUIT
+2 ;
WARN ;
+1 ;If the whole entry is being deleted don't give the warning.
+2 IF $GET(PXRMDEFD)
QUIT
+3 IF $GET(PXRMTMD)
QUIT
+4 ;Do not execute as part of exchange.
+5 IF $GET(PXRMEXCH)
QUIT
+6 NEW TEXT
+7 SET TEXT(1)=""
+8 SET TEXT(2)="Since you changed the value of Rx Type, you should review the status list"
+9 SET TEXT(3)="for the finding to make sure it is still appropriate."
+10 SET TEXT(4)=""
+11 DO EN^DDIOL(.TEXT)
+12 QUIT
+13 ;
