PXRMTXSM ;SLC/PKR - Reminder Taxonomy ScreenMan routines ;06/14/2022
;;2.0;CLINICAL REMINDERS;**26,47,42,65**;Feb 04, 2005;Build 438
;
;===============
CODELIST(TAXIEN) ;See if the temporary list of selected codes exists,
;if it does not and codes have been stored in the taxonomy
;then build it.
I $D(^TMP("PXRMCODES",$J)) Q
I '$D(^PXD(811.2,TAXIEN,20,"ATCC")) Q
M ^TMP("PXRMCODES",$J)=^PXD(811.2,TAXIEN,20,"ATC")
M ^TMP("PXRMCODES",$J)=^PXD(811.2,TAXIEN,20,"ATCC")
Q
;
;===============
EXETCCAP(DA) ;Executable caption for code search.
N TC
S TC=$$GET^DDSVAL(811.23,.DA,.01,"","E")
I $L(TC)>57 S TC=$E(TC,1,54)_"..."
Q " Term/Code: "_TC_" "
;
;===============
FDATAVAL(IEN) ;Form Data Validation.
;If either MINIMUM VALUE or MAXIMUM VALUE is defined, they both must be.
N MAX,MAXDEC,MIN,PROMPT,TEXT,UCUM,UDISPLAY
S MIN=$$GET^DDSVAL(811.2,IEN,220)
S MAX=$$GET^DDSVAL(811.2,IEN,221)
S MAXDEC=$$GET^DDSVAL(811.2,IEN,222)
S UCUM=$$GET^DDSVAL(811.2,IEN,223)
S PROMPT=$$GET^DDSVAL(811.2,IEN,224)
S UDISPLAY=$$GET^DDSVAL(811.2,IEN,225)
I (MIN=""),(MAX=""),(MAXDEC=""),(UCUM=""),(PROMPT=""),(UDISPLAY="") G SPONCLASS
;If any of the measurement fields are defined they all must be.
I (MIN="")!(MAX="")!(MAXDEC="")!(UCUM="")!(PROMPT="")!(UDISPLAY="") D Q
. S TEXT="If any of the measurement fields are defined, they all must be."
. D HLP^DDSUTL(.TEXT)
. S DDSBR="MINIMUM VALUE",DDSERROR=1
I MAX<MIN D Q
. S TEXT="The Maximum Value cannot be less than the Minimum Value."
. D HLP^DDSUTL(.TEXT)
. S DDSBR="MAXIMUM VALUE",DDSERROR=1
SPONCLASS ;Make sure the Class of the Sponsor matches that of the Taxonomy.
N CLASS,ERROR,NAME,SCLASS,SIEN
S CLASS=$$GET^DDSVAL(811.2,IEN,100,.ERROR,"I")
S SIEN=$$GET^DDSVAL(811.2,IEN,101,.ERROR,"I")
S SCLASS=$S(SIEN="":"",1:$$GET1^DIQ(811.6,SIEN,100,"I"))
I (SCLASS'=""),(SCLASS'=CLASS) D
. S TEXT="Sponsor Class is "_SCLASS_", Taxonomy Class is "_CLASS_" they must match!"
. D HLP^DDSUTL(.TEXT)
. S DDSBR="CLASS",DDSERROR=1
;If the Name starts with VA- make sure the Class is National.
S NAME=$$GET^DDSVAL(811.2,IEN,.01,.ERROR,"I")
I $E(NAME,1,3)="VA-",CLASS'="N" D
. S TEXT="Name starts with 'VA-', but the Class is not National."
. D HLP^DDSUTL(.TEXT)
. S DDSBR="NAME",DDSERROR=1
Q
;
;===============
LEXSRCH(DA,CODESYS) ;Branch for Lexicon Term/Code search.
;selection.
N PXRMLEXV,SAVEDDS,TAXIEN,TERM
;These PXRM variables are used in the List Manager Lexicon search.
N PXRMBGS,PXRMLEXV
K ^TMP("PXRMLEXTC",$J)
S ^TMP("PXRMLEXTC",$J,"CODESYS")=CODESYS
S (^TMP("PXRMLEXTC",$J,"LEX TERM"),TERM)=$$GET^DDSVAL(811.23,.DA,.01,"","E")
S (^TMP("PXRMLEXTC",$J,"TAX IEN"),TAXIEN)=DA(1)
;DBIA #5746 covers kill and set of DDS.
I $D(DDS) S SAVEDDS=DDS K DDS
D EN^VALM("PXRM LEXICON SELECT")
K ^TMP("PXRMLEXTC",$J)
;Reset the screen so ScreenMan displays properly.
I $D(SAVEDDS) D
. N IOAWM0,X
. S DDS=SAVEDDS
. S X=0 X ^%ZOSF("RM"),^%ZOSF("TYPE-AHEAD")
. S X="IOAWM0" D ENDR^%ZISS W IOAWM0
. D REFRESH^DDSUTL
Q
;
;===============
LTCPAOC(DA) ;Lexicon Term/Code post-action on change.
N NTC,OTC,TEXT
S NTC=$$GET^DDSVAL(811.23,.DA,"TERM/CODE")
S OTC=$G(^PXD(811.2,DA(1),20,DA,0))
I ($L(OTC)>0),(NTC'=OTC) D
. S TEXT(1)="Overwriting a search Term/Code is not allowed!"
. S TEXT(2)="To replace a search term delete the existing one first."
. S TEXT(3)="$$EOP"
. D HLP^DDSUTL(.TEXT)
. D PUT^DDSVAL(811.23,.DA,"TERM/CODE",OTC)
Q
;
;===============
NUMCODES(DA) ;Executable caption to display the number of selected codes
;for Lexicon Term/Code.
;^TMP("PXRMCODES",$J) will have the value from the current editing
;session so check it first.
I DA="" Q $$REPEAT^XLFSTR(" ",30)
N TERM
S TERM=$$GET^DDSVAL(811.23,.DA,.01,"","E")
I TERM="" Q $$REPEAT^XLFSTR(" ",30)
N CODESYS,COUNT,ERROR,IND,NUID,NUM,TEMP,TEXT,UID
S CODESYS=""
F S CODESYS=$O(^TMP("PXRMCODES",$J,TERM,CODESYS)) Q:CODESYS="" D
. S CODE="",(NUID,NUM)=0
. F S CODE=$O(^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)) Q:CODE="" D
.. S NUM=NUM+1
.. S UID=^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)
.. I UID=1 S NUID=NUID+1
. S COUNT(CODESYS)=NUM
. S NUID(CODESYS)=NUID
;If nothing was found for this term in ^TMP("PXRMCODES"), check for
;stored values.
S IND=0
F S IND=+$O(^PXD(811.2,DA(1),20,DA,1,IND)) Q:IND=0 D
. S TEMP=^PXD(811.2,DA(1),20,DA,1,IND,0)
. S CODESYS=$P(TEMP,U,1),NUM=$P(TEMP,U,2),NUID=$P(TEMP,U,3)
.;If COUNT is already defined for this CODESYS don't get the stored
.;values.
. I $D(COUNT(CODESYS))!(NUM=0) Q
. S COUNT(CODESYS)=NUM
. S NUID(CODESYS)=NUID
I '$D(COUNT) Q "None"_$$REPEAT^XLFSTR(" ",26)
S (CODESYS,TEXT)=""
F S CODESYS=$O(COUNT(CODESYS)) Q:CODESYS="" D
. S TEXT=TEXT_CODESYS_":"_COUNT(CODESYS)
. I NUID(CODESYS)>0 S TEXT=TEXT_":"_NUID(CODESYS)
. S TEXT=TEXT_" "
S NUM=$L(TEXT)
I NUM<30 S TEXT=TEXT_$$REPEAT^XLFSTR(" ",(30-NUM))
Q TEXT
;
;===============
POSTACT(D0) ;Form Post Action
;DX and DY should not be newed or killed, control by ScreenMan
N INACTIVE,INUSE,OUTPUT
K ^TMP("PXRMCODES",$J)
;If the change was a deletion there is nothing else to do.
I '$D(^PXD(811.2,D0)) Q
;If the taxonomy was inactivated check to see if it is being used.
S INACTIVE=$$GET^DDSVAL(811.2,D0,"INACTIVE FLAG")
S INUSE=$S(INACTIVE:$$INUSE^PXRMTAXD(D0,"INACT"),1:0)
I INUSE D HLP^DDSUTL("$$EOP")
;Check for dialog problems.
D TAXEDITC^PXRMDTAX(D0,.OUTPUT)
I $D(OUTPUT) D
. D BROWSE^DDBR("OUTPUT","NR","Problems with dialogs using this taxonomy.")
. I $D(DDS) D REFRESH^DDSUTL S DY=IOSL-7,DX=0 X IOXY S $Y=DY,$X=DX
Q
;
;===============
POSTSAVE(IEN) ;Form Post Save. Store changes in lists of codes.
N CODE,CODESYS,CSYSIND,DELTERM,FDA,KCSYSIND,KFDA,MSG,NSEL,NUID,PDS
N TEMP,TERM,TERMIND,TEXT,UID
S TERM="",TERMIND=0
F S TERM=$O(^TMP("PXRMCODES",$J,TERM)) Q:TERM="" D
.;If this term has been deleted, skip the rest.
. I '$D(^PXD(811.2,IEN,20,"B",TERM)) Q
. S TERMIND=$O(^PXD(811.2,IEN,20,"B",TERM,""))
. S DELTERM=$G(^TMP("PXRMCODES",$J,TERM))
. I DELTERM="@" D Q
.. S IENS=TERMIND_","_IEN_","
.. S KFDA(811.23,IENS,.01)="@"
.. D FILE^DIE("","KFDA","MSG")
. S CODESYS="",CSYSIND=TERMIND
. F S CODESYS=$O(^TMP("PXRMCODES",$J,TERM,CODESYS)) Q:CODESYS="" D
..;Check for existing entries for this term and this coding system.
..;If there are any remove them before storing the new set.
.. I $D(^PXD(811.2,IEN,20,"ATC",TERM,CODESYS)) D
... S KCSYSIND=$P(^PXD(811.2,IEN,20,"ATC",TERM,CODESYS),U,2)
... S IENS=KCSYSIND_","_TERMIND_","_IEN_","
... S KFDA(811.231,IENS,.01)="@"
... D FILE^DIE("","KFDA","MSG")
.. S CSYSIND=CSYSIND+1
.. S (NSEL,NUID)=0,CODE=""
.. F S CODE=$O(^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)) Q:CODE="" D
... S NSEL=NSEL+1
... S UID=^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)
... I UID=1 S NUID=NUID+1
... S IENS="+"_(NSEL+CSYSIND)_",+"_CSYSIND_","_TERMIND_","_IEN_","
... S FDA(811.2312,IENS,.01)=CODE
... S FDA(811.2312,IENS,1)=UID
.. I NSEL>0 D
... S IENS="+"_CSYSIND_","_TERMIND_","_IEN_","
... S FDA(811.231,IENS,.01)=CODESYS
... S FDA(811.231,IENS,1)=NSEL
... S FDA(811.231,IENS,3)=NUID
... S CSYSIND=NSEL+CSYSIND
. I $D(FDA) D UPDATE^DIE("","FDA","","MSG")
. I $D(MSG) D
.. S TEXT(1)="Error storing codes for term "_TERM
.. S TEXT(2)=" coding system "_CODESYS
.. D EN^DDIOL(.TEXT)
.. D AWRITE^PXRMUTIL("MSG")
.. H 2
K ^TMP("PXRMCODES",$J)
;Reset the 811.23 0 node so holes are not left.
I $D(^PXD(811.2,IEN,20)) S $P(^PXD(811.2,IEN,20,0),U,3)=0
;Make sure Patient Data Source index is built.
S PDS=$$GET^DDSVAL(811.2,IEN,"PATIENT DATA SOURCE")
I PDS="" D SPDS^PXRMPDS(IEN,PDS)
Q
;
;===============
SMANEDIT(IEN,NEW,FORM) ;ScreenMan edit for entry IEN.
N CLASS,DA,DDSCHANG,DDSFILE,DDSPARM,DDSSAVE,DEL,DIDEL,DIMSG,DR,DTOUT
N HASH256,OCLOG,NATOK,SHASH256
S (DDSFILE,DIDEL)=811.2,DDSPARM="CS",DR="["_FORM_"]"
S CLASS=$P(^PXD(811.2,IEN,100),U,1)
S NATOK=$S(CLASS'="N":1,1:($G(PXRMINST)=1)&($G(DUZ(0))="@"))
I 'NATOK D Q
. W !,"National taxonomies cannot be edited."
. H 2
. S VALMBCK="R"
S NEW=$G(NEW)
;These ^TMP entries are used by the Lexicon display to store the
;results of the search and selection. Initializing them here minimizes
;the number of Lexicon searches.
K ^TMP("PXRMCODES",$J),^TMP("PXRMLEXS",$J),^TMP("PXRMTEXT",$J)
;Initialize the code list.
D CODELIST(IEN)
S SHASH256=$$FILE^XLFSHAN(256,811.2,IEN)
S DA=IEN
D ^DDS
K ^TMP("PXRMCODES",$J),^TMP("PXRMLEXS",$J),^TMP("PXRMTEXT",$J)
I $D(DIMSG) H 2
;If the entry is new and the user did not save, delete it.
I NEW,$G(DDSSAVE)'=1 D DELETE^PXRMEXFI(811.2,IEN) Q
;If changes were made update the change log and rebuild the
;List Manager list. However, if the change was a deletion skip
;the change log.
S DEL=$S($D(^PXD(811.2,IEN)):0,1:1)
I DEL&(FORM="PXRM TAXONOMY EDIT") D Q
. D BLDLIST^PXRMTAXL("PXRMTAXL")
. S VALMBCK="R"
I NEW S OCLOG=1
E S HASH256=$$FILE^XLFSHAN(256,811.2,IEN),OCLOG=$S(HASH256=SHASH256:0,1:1)
I 'OCLOG S VALMBCK="R" Q
;Open the Change Log
N IENS,FDA,FDAIEN,MSG,WPTMP
S IENS="+1,"_IEN_","
S FDA(811.21,IENS,.01)=$$NOW^XLFDT
S FDA(811.21,IENS,1)=DUZ
I NEW D
. S WPTMP(1,1,1)=" Creation."
. S FDA(811.21,IENS,2)="WPTMP(1,1)"
D UPDATE^DIE("S","FDA","FDAIEN","MSG")
K DA,DDSFILE
S DA=FDAIEN(1),DA(1)=IEN
S DDSFILE=811.2,DDSFILE(1)=811.21
S DR="[PXRM TAXONOMY CHANGE LOG]"
D ^DDS
I (FORM="PXRM TAXONOMY EDIT") D BLDLIST^PXRMTAXL("PXRMTAXL") S VALMBCK="R"
Q
;
;===============
VEALLSEL(DA) ;Branch for View/edit all selected codes.
;selection.
N PXRMLEXV,SAVEDDS
K ^TMP("PXRMTAX",$J)
S ^TMP("PXRMTAX",$J,"TAXIEN")=DA
;DBIA #5746 covers kill and set of DDS.
I $D(DDS) S SAVEDDS=DDS K DDS
D EN^VALM("PXRM TAXONOMY ALL SELECTED")
K ^TMP("PXRMTAX",$J)
;Reset the screen so ScreenMan displays properly.
I $D(SAVEDDS) D
. N IOAWM0,X
. S DDS=SAVEDDS
. S X=0 X ^%ZOSF("RM"),^%ZOSF("TYPE-AHEAD")
. S X="IOAWM0" D ENDR^%ZISS W IOAWM0
. D REFRESH^DDSUTL
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMTXSM 10158 printed Mar 13, 2025@20:54:18 Page 2
PXRMTXSM ;SLC/PKR - Reminder Taxonomy ScreenMan routines ;06/14/2022
+1 ;;2.0;CLINICAL REMINDERS;**26,47,42,65**;Feb 04, 2005;Build 438
+2 ;
+3 ;===============
CODELIST(TAXIEN) ;See if the temporary list of selected codes exists,
+1 ;if it does not and codes have been stored in the taxonomy
+2 ;then build it.
+3 IF $DATA(^TMP("PXRMCODES",$JOB))
QUIT
+4 IF '$DATA(^PXD(811.2,TAXIEN,20,"ATCC"))
QUIT
+5 MERGE ^TMP("PXRMCODES",$JOB)=^PXD(811.2,TAXIEN,20,"ATC")
+6 MERGE ^TMP("PXRMCODES",$JOB)=^PXD(811.2,TAXIEN,20,"ATCC")
+7 QUIT
+8 ;
+9 ;===============
EXETCCAP(DA) ;Executable caption for code search.
+1 NEW TC
+2 SET TC=$$GET^DDSVAL(811.23,.DA,.01,"","E")
+3 IF $LENGTH(TC)>57
SET TC=$EXTRACT(TC,1,54)_"..."
+4 QUIT " Term/Code: "_TC_" "
+5 ;
+6 ;===============
FDATAVAL(IEN) ;Form Data Validation.
+1 ;If either MINIMUM VALUE or MAXIMUM VALUE is defined, they both must be.
+2 NEW MAX,MAXDEC,MIN,PROMPT,TEXT,UCUM,UDISPLAY
+3 SET MIN=$$GET^DDSVAL(811.2,IEN,220)
+4 SET MAX=$$GET^DDSVAL(811.2,IEN,221)
+5 SET MAXDEC=$$GET^DDSVAL(811.2,IEN,222)
+6 SET UCUM=$$GET^DDSVAL(811.2,IEN,223)
+7 SET PROMPT=$$GET^DDSVAL(811.2,IEN,224)
+8 SET UDISPLAY=$$GET^DDSVAL(811.2,IEN,225)
+9 IF (MIN="")
IF (MAX="")
IF (MAXDEC="")
IF (UCUM="")
IF (PROMPT="")
IF (UDISPLAY="")
GOTO SPONCLASS
+10 ;If any of the measurement fields are defined they all must be.
+11 IF (MIN="")!(MAX="")!(MAXDEC="")!(UCUM="")!(PROMPT="")!(UDISPLAY="")
Begin DoDot:1
+12 SET TEXT="If any of the measurement fields are defined, they all must be."
+13 DO HLP^DDSUTL(.TEXT)
+14 SET DDSBR="MINIMUM VALUE"
SET DDSERROR=1
End DoDot:1
QUIT
+15 IF MAX<MIN
Begin DoDot:1
+16 SET TEXT="The Maximum Value cannot be less than the Minimum Value."
+17 DO HLP^DDSUTL(.TEXT)
+18 SET DDSBR="MAXIMUM VALUE"
SET DDSERROR=1
End DoDot:1
QUIT
SPONCLASS ;Make sure the Class of the Sponsor matches that of the Taxonomy.
+1 NEW CLASS,ERROR,NAME,SCLASS,SIEN
+2 SET CLASS=$$GET^DDSVAL(811.2,IEN,100,.ERROR,"I")
+3 SET SIEN=$$GET^DDSVAL(811.2,IEN,101,.ERROR,"I")
+4 SET SCLASS=$SELECT(SIEN="":"",1:$$GET1^DIQ(811.6,SIEN,100,"I"))
+5 IF (SCLASS'="")
IF (SCLASS'=CLASS)
Begin DoDot:1
+6 SET TEXT="Sponsor Class is "_SCLASS_", Taxonomy Class is "_CLASS_" they must match!"
+7 DO HLP^DDSUTL(.TEXT)
+8 SET DDSBR="CLASS"
SET DDSERROR=1
End DoDot:1
+9 ;If the Name starts with VA- make sure the Class is National.
+10 SET NAME=$$GET^DDSVAL(811.2,IEN,.01,.ERROR,"I")
+11 IF $EXTRACT(NAME,1,3)="VA-"
IF CLASS'="N"
Begin DoDot:1
+12 SET TEXT="Name starts with 'VA-', but the Class is not National."
+13 DO HLP^DDSUTL(.TEXT)
+14 SET DDSBR="NAME"
SET DDSERROR=1
End DoDot:1
+15 QUIT
+16 ;
+17 ;===============
LEXSRCH(DA,CODESYS) ;Branch for Lexicon Term/Code search.
+1 ;selection.
+2 NEW PXRMLEXV,SAVEDDS,TAXIEN,TERM
+3 ;These PXRM variables are used in the List Manager Lexicon search.
+4 NEW PXRMBGS,PXRMLEXV
+5 KILL ^TMP("PXRMLEXTC",$JOB)
+6 SET ^TMP("PXRMLEXTC",$JOB,"CODESYS")=CODESYS
+7 SET (^TMP("PXRMLEXTC",$JOB,"LEX TERM"),TERM)=$$GET^DDSVAL(811.23,.DA,.01,"","E")
+8 SET (^TMP("PXRMLEXTC",$JOB,"TAX IEN"),TAXIEN)=DA(1)
+9 ;DBIA #5746 covers kill and set of DDS.
+10 IF $DATA(DDS)
SET SAVEDDS=DDS
KILL DDS
+11 DO EN^VALM("PXRM LEXICON SELECT")
+12 KILL ^TMP("PXRMLEXTC",$JOB)
+13 ;Reset the screen so ScreenMan displays properly.
+14 IF $DATA(SAVEDDS)
Begin DoDot:1
+15 NEW IOAWM0,X
+16 SET DDS=SAVEDDS
+17 SET X=0
XECUTE ^%ZOSF("RM")
XECUTE ^%ZOSF("TYPE-AHEAD")
+18 SET X="IOAWM0"
DO ENDR^%ZISS
WRITE IOAWM0
+19 DO REFRESH^DDSUTL
End DoDot:1
+20 QUIT
+21 ;
+22 ;===============
LTCPAOC(DA) ;Lexicon Term/Code post-action on change.
+1 NEW NTC,OTC,TEXT
+2 SET NTC=$$GET^DDSVAL(811.23,.DA,"TERM/CODE")
+3 SET OTC=$GET(^PXD(811.2,DA(1),20,DA,0))
+4 IF ($LENGTH(OTC)>0)
IF (NTC'=OTC)
Begin DoDot:1
+5 SET TEXT(1)="Overwriting a search Term/Code is not allowed!"
+6 SET TEXT(2)="To replace a search term delete the existing one first."
+7 SET TEXT(3)="$$EOP"
+8 DO HLP^DDSUTL(.TEXT)
+9 DO PUT^DDSVAL(811.23,.DA,"TERM/CODE",OTC)
End DoDot:1
+10 QUIT
+11 ;
+12 ;===============
NUMCODES(DA) ;Executable caption to display the number of selected codes
+1 ;for Lexicon Term/Code.
+2 ;^TMP("PXRMCODES",$J) will have the value from the current editing
+3 ;session so check it first.
+4 IF DA=""
QUIT $$REPEAT^XLFSTR(" ",30)
+5 NEW TERM
+6 SET TERM=$$GET^DDSVAL(811.23,.DA,.01,"","E")
+7 IF TERM=""
QUIT $$REPEAT^XLFSTR(" ",30)
+8 NEW CODESYS,COUNT,ERROR,IND,NUID,NUM,TEMP,TEXT,UID
+9 SET CODESYS=""
+10 FOR
SET CODESYS=$ORDER(^TMP("PXRMCODES",$JOB,TERM,CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+11 SET CODE=""
SET (NUID,NUM)=0
+12 FOR
SET CODE=$ORDER(^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:2
+13 SET NUM=NUM+1
+14 SET UID=^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE)
+15 IF UID=1
SET NUID=NUID+1
End DoDot:2
+16 SET COUNT(CODESYS)=NUM
+17 SET NUID(CODESYS)=NUID
End DoDot:1
+18 ;If nothing was found for this term in ^TMP("PXRMCODES"), check for
+19 ;stored values.
+20 SET IND=0
+21 FOR
SET IND=+$ORDER(^PXD(811.2,DA(1),20,DA,1,IND))
if IND=0
QUIT
Begin DoDot:1
+22 SET TEMP=^PXD(811.2,DA(1),20,DA,1,IND,0)
+23 SET CODESYS=$PIECE(TEMP,U,1)
SET NUM=$PIECE(TEMP,U,2)
SET NUID=$PIECE(TEMP,U,3)
+24 ;If COUNT is already defined for this CODESYS don't get the stored
+25 ;values.
+26 IF $DATA(COUNT(CODESYS))!(NUM=0)
QUIT
+27 SET COUNT(CODESYS)=NUM
+28 SET NUID(CODESYS)=NUID
End DoDot:1
+29 IF '$DATA(COUNT)
QUIT "None"_$$REPEAT^XLFSTR(" ",26)
+30 SET (CODESYS,TEXT)=""
+31 FOR
SET CODESYS=$ORDER(COUNT(CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+32 SET TEXT=TEXT_CODESYS_":"_COUNT(CODESYS)
+33 IF NUID(CODESYS)>0
SET TEXT=TEXT_":"_NUID(CODESYS)
+34 SET TEXT=TEXT_" "
End DoDot:1
+35 SET NUM=$LENGTH(TEXT)
+36 IF NUM<30
SET TEXT=TEXT_$$REPEAT^XLFSTR(" ",(30-NUM))
+37 QUIT TEXT
+38 ;
+39 ;===============
POSTACT(D0) ;Form Post Action
+1 ;DX and DY should not be newed or killed, control by ScreenMan
+2 NEW INACTIVE,INUSE,OUTPUT
+3 KILL ^TMP("PXRMCODES",$JOB)
+4 ;If the change was a deletion there is nothing else to do.
+5 IF '$DATA(^PXD(811.2,D0))
QUIT
+6 ;If the taxonomy was inactivated check to see if it is being used.
+7 SET INACTIVE=$$GET^DDSVAL(811.2,D0,"INACTIVE FLAG")
+8 SET INUSE=$SELECT(INACTIVE:$$INUSE^PXRMTAXD(D0,"INACT"),1:0)
+9 IF INUSE
DO HLP^DDSUTL("$$EOP")
+10 ;Check for dialog problems.
+11 DO TAXEDITC^PXRMDTAX(D0,.OUTPUT)
+12 IF $DATA(OUTPUT)
Begin DoDot:1
+13 DO BROWSE^DDBR("OUTPUT","NR","Problems with dialogs using this taxonomy.")
+14 IF $DATA(DDS)
DO REFRESH^DDSUTL
SET DY=IOSL-7
SET DX=0
XECUTE IOXY
SET $Y=DY
SET $X=DX
End DoDot:1
+15 QUIT
+16 ;
+17 ;===============
POSTSAVE(IEN) ;Form Post Save. Store changes in lists of codes.
+1 NEW CODE,CODESYS,CSYSIND,DELTERM,FDA,KCSYSIND,KFDA,MSG,NSEL,NUID,PDS
+2 NEW TEMP,TERM,TERMIND,TEXT,UID
+3 SET TERM=""
SET TERMIND=0
+4 FOR
SET TERM=$ORDER(^TMP("PXRMCODES",$JOB,TERM))
if TERM=""
QUIT
Begin DoDot:1
+5 ;If this term has been deleted, skip the rest.
+6 IF '$DATA(^PXD(811.2,IEN,20,"B",TERM))
QUIT
+7 SET TERMIND=$ORDER(^PXD(811.2,IEN,20,"B",TERM,""))
+8 SET DELTERM=$GET(^TMP("PXRMCODES",$JOB,TERM))
+9 IF DELTERM="@"
Begin DoDot:2
+10 SET IENS=TERMIND_","_IEN_","
+11 SET KFDA(811.23,IENS,.01)="@"
+12 DO FILE^DIE("","KFDA","MSG")
End DoDot:2
QUIT
+13 SET CODESYS=""
SET CSYSIND=TERMIND
+14 FOR
SET CODESYS=$ORDER(^TMP("PXRMCODES",$JOB,TERM,CODESYS))
if CODESYS=""
QUIT
Begin DoDot:2
+15 ;Check for existing entries for this term and this coding system.
+16 ;If there are any remove them before storing the new set.
+17 IF $DATA(^PXD(811.2,IEN,20,"ATC",TERM,CODESYS))
Begin DoDot:3
+18 SET KCSYSIND=$PIECE(^PXD(811.2,IEN,20,"ATC",TERM,CODESYS),U,2)
+19 SET IENS=KCSYSIND_","_TERMIND_","_IEN_","
+20 SET KFDA(811.231,IENS,.01)="@"
+21 DO FILE^DIE("","KFDA","MSG")
End DoDot:3
+22 SET CSYSIND=CSYSIND+1
+23 SET (NSEL,NUID)=0
SET CODE=""
+24 FOR
SET CODE=$ORDER(^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:3
+25 SET NSEL=NSEL+1
+26 SET UID=^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE)
+27 IF UID=1
SET NUID=NUID+1
+28 SET IENS="+"_(NSEL+CSYSIND)_",+"_CSYSIND_","_TERMIND_","_IEN_","
+29 SET FDA(811.2312,IENS,.01)=CODE
+30 SET FDA(811.2312,IENS,1)=UID
End DoDot:3
+31 IF NSEL>0
Begin DoDot:3
+32 SET IENS="+"_CSYSIND_","_TERMIND_","_IEN_","
+33 SET FDA(811.231,IENS,.01)=CODESYS
+34 SET FDA(811.231,IENS,1)=NSEL
+35 SET FDA(811.231,IENS,3)=NUID
+36 SET CSYSIND=NSEL+CSYSIND
End DoDot:3
End DoDot:2
+37 IF $DATA(FDA)
DO UPDATE^DIE("","FDA","","MSG")
+38 IF $DATA(MSG)
Begin DoDot:2
+39 SET TEXT(1)="Error storing codes for term "_TERM
+40 SET TEXT(2)=" coding system "_CODESYS
+41 DO EN^DDIOL(.TEXT)
+42 DO AWRITE^PXRMUTIL("MSG")
+43 HANG 2
End DoDot:2
End DoDot:1
+44 KILL ^TMP("PXRMCODES",$JOB)
+45 ;Reset the 811.23 0 node so holes are not left.
+46 IF $DATA(^PXD(811.2,IEN,20))
SET $PIECE(^PXD(811.2,IEN,20,0),U,3)=0
+47 ;Make sure Patient Data Source index is built.
+48 SET PDS=$$GET^DDSVAL(811.2,IEN,"PATIENT DATA SOURCE")
+49 IF PDS=""
DO SPDS^PXRMPDS(IEN,PDS)
+50 QUIT
+51 ;
+52 ;===============
SMANEDIT(IEN,NEW,FORM) ;ScreenMan edit for entry IEN.
+1 NEW CLASS,DA,DDSCHANG,DDSFILE,DDSPARM,DDSSAVE,DEL,DIDEL,DIMSG,DR,DTOUT
+2 NEW HASH256,OCLOG,NATOK,SHASH256
+3 SET (DDSFILE,DIDEL)=811.2
SET DDSPARM="CS"
SET DR="["_FORM_"]"
+4 SET CLASS=$PIECE(^PXD(811.2,IEN,100),U,1)
+5 SET NATOK=$SELECT(CLASS'="N":1,1:($GET(PXRMINST)=1)&($GET(DUZ(0))="@"))
+6 IF 'NATOK
Begin DoDot:1
+7 WRITE !,"National taxonomies cannot be edited."
+8 HANG 2
+9 SET VALMBCK="R"
End DoDot:1
QUIT
+10 SET NEW=$GET(NEW)
+11 ;These ^TMP entries are used by the Lexicon display to store the
+12 ;results of the search and selection. Initializing them here minimizes
+13 ;the number of Lexicon searches.
+14 KILL ^TMP("PXRMCODES",$JOB),^TMP("PXRMLEXS",$JOB),^TMP("PXRMTEXT",$JOB)
+15 ;Initialize the code list.
+16 DO CODELIST(IEN)
+17 SET SHASH256=$$FILE^XLFSHAN(256,811.2,IEN)
+18 SET DA=IEN
+19 DO ^DDS
+20 KILL ^TMP("PXRMCODES",$JOB),^TMP("PXRMLEXS",$JOB),^TMP("PXRMTEXT",$JOB)
+21 IF $DATA(DIMSG)
HANG 2
+22 ;If the entry is new and the user did not save, delete it.
+23 IF NEW
IF $GET(DDSSAVE)'=1
DO DELETE^PXRMEXFI(811.2,IEN)
QUIT
+24 ;If changes were made update the change log and rebuild the
+25 ;List Manager list. However, if the change was a deletion skip
+26 ;the change log.
+27 SET DEL=$SELECT($DATA(^PXD(811.2,IEN)):0,1:1)
+28 IF DEL&(FORM="PXRM TAXONOMY EDIT")
Begin DoDot:1
+29 DO BLDLIST^PXRMTAXL("PXRMTAXL")
+30 SET VALMBCK="R"
End DoDot:1
QUIT
+31 IF NEW
SET OCLOG=1
+32 IF '$TEST
SET HASH256=$$FILE^XLFSHAN(256,811.2,IEN)
SET OCLOG=$SELECT(HASH256=SHASH256:0,1:1)
+33 IF 'OCLOG
SET VALMBCK="R"
QUIT
+34 ;Open the Change Log
+35 NEW IENS,FDA,FDAIEN,MSG,WPTMP
+36 SET IENS="+1,"_IEN_","
+37 SET FDA(811.21,IENS,.01)=$$NOW^XLFDT
+38 SET FDA(811.21,IENS,1)=DUZ
+39 IF NEW
Begin DoDot:1
+40 SET WPTMP(1,1,1)=" Creation."
+41 SET FDA(811.21,IENS,2)="WPTMP(1,1)"
End DoDot:1
+42 DO UPDATE^DIE("S","FDA","FDAIEN","MSG")
+43 KILL DA,DDSFILE
+44 SET DA=FDAIEN(1)
SET DA(1)=IEN
+45 SET DDSFILE=811.2
SET DDSFILE(1)=811.21
+46 SET DR="[PXRM TAXONOMY CHANGE LOG]"
+47 DO ^DDS
+48 IF (FORM="PXRM TAXONOMY EDIT")
DO BLDLIST^PXRMTAXL("PXRMTAXL")
SET VALMBCK="R"
+49 QUIT
+50 ;
+51 ;===============
VEALLSEL(DA) ;Branch for View/edit all selected codes.
+1 ;selection.
+2 NEW PXRMLEXV,SAVEDDS
+3 KILL ^TMP("PXRMTAX",$JOB)
+4 SET ^TMP("PXRMTAX",$JOB,"TAXIEN")=DA
+5 ;DBIA #5746 covers kill and set of DDS.
+6 IF $DATA(DDS)
SET SAVEDDS=DDS
KILL DDS
+7 DO EN^VALM("PXRM TAXONOMY ALL SELECTED")
+8 KILL ^TMP("PXRMTAX",$JOB)
+9 ;Reset the screen so ScreenMan displays properly.
+10 IF $DATA(SAVEDDS)
Begin DoDot:1
+11 NEW IOAWM0,X
+12 SET DDS=SAVEDDS
+13 SET X=0
XECUTE ^%ZOSF("RM")
XECUTE ^%ZOSF("TYPE-AHEAD")
+14 SET X="IOAWM0"
DO ENDR^%ZISS
WRITE IOAWM0
+15 DO REFRESH^DDSUTL
End DoDot:1
+16 QUIT
+17 ;
