source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMSTA1.m@ 1397

PXRMSTA1 ; SLC/AGP - Routines for building status list. ;09/06/2007
 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
 ;
 ;This routine and PXRMSTA2 will allow users to select the
 ;approriate status for Orders, Medication, Taxonomy, Problem List,
 ;and Radiology Procedure findings items.
 ;
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
 ;
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)
 ;I FILE="T",$P($G(@GBL@(DA(2),20,DA(1),5,0)),U,4)>0 D
 ;.S STS="" F  S STS=$O(@GBL@(DA(2),20,DA(1),5,"B",STS)) Q:STS=""  S DELSTS(STS)=""
 ;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
 ;
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
 ;
ADD(GBL,FILE,CSTATUS,TYPE,WILD,DA,UPDATE) ;
 N ANS,STATUS,TERMIEN
 ;Find what types of finding is 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)
 .;I $G(TAXTYPE)="P" D DATA^PXRMSTA2(FILE,.DA,"PROB","",.STATUS)
 .;I $G(TAXTYPE)="B" D DATA^PXRMSTA2(FILE,.DA,"TAX","",.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
 ;
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 $G(TAXTYPE)="P" S FILE=9000011
 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
 ;.S DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5," 
 ;D CLEAR(GBL,FILE,.DA)
 ;I $D(CSTATUS)'>0 S DA=0 F  S DA=$O(^PXRMD(811.5,DA(2),20,DA(1),5,DA)) Q:DA'>0  D ^DIK
 ;I '$D(CSTATUS) D CLEAR(GBL,FILE,.DA) D DEFAULT(GBL,TYPE,NODE,FILE,1,.DA)
 ;I '$D(CSTATUS),FILE="D" D DEFAULT(GBL,TYPE,NODE,FILE,1,.DA)
 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=1 D 
 ;.F  S NAME=$O(@GBL@(DA(2),20,DA(1),5,"B",NAME)) Q:NAME=""  D
 ;..S CSTATUS(NAME)=$O(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME",""))
 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
 ;
 ;
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
 ;
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
 ;
ASK(STR,HTEXT) ;
 N DIR,HTEXT
 I '$D(HTEXT) D
 .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
 ;
TAXTYPE(TERMIEN,HELP) ;
 ;use to 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,$G(HELP))
 .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
 ;
TAXNODE(TAXIEN,HELP) ;
 ;use to determine the type of taxonomy
 N TAXNODE,ICD,CPT,ARRAY,RAD,PL,BOTH,RADM,PLM,RESULT
 S (BOTH,PL,PLM,RAD,RADM,RESULT)=0
 D CHECK^PXRMBXTL(TAXIEN,"")
 I $D(^PXD(811.3,TAXIEN,71,"RCPTP"))>0 S RAD=1
 I $D(^PXD(811.3,TAXIEN,"PDS",9000011))>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
 ;
 ;
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
 ;
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
 ;
 ;