PXEDUSM ;SLC/PKR - Education Topics ScreenMan routines ;06/14/2022
;;1.0;PCE PATIENT CARE ENCOUNTER;**211,217**;Aug 12, 1996;Build 134
;
;===============
CODEPAOC(DA) ;Code Post-Action On Change.
N CODE,CODESYS,NEWCODE,SAVEDDS
S CODESYS=$$GET^DDSVAL(9999999.11,.DA,.01)
S CODE=$$GET^DDSVAL(9999999.11,.DA,1)
;DBIA #5746 covers kill and set of DDS.
I $D(DDS) S SAVEDDS=DDS K DDS
;Call the Lexicon search.
S NEWCODE=$$GETCODE^PXLEXS(CODESYS,CODE,DT,0)
;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
D PUT^DDSVAL(9999999.11,.DA,1,NEWCODE)
Q
;
;===============
CODEPRE(DA) ;Code pre-action.
N CODESYS,TEXT
S CODESYS=$$GET^DDSVAL(9999999.11,.DA,.01)
;ICR #5679
S CODESYS=$P($$CSYS^LEXU(CODESYS),U,4)
S TEXT(1)="Input a search term or a "_CODESYS_" code."
D EN^DDIOL(.TEXT)
Q
;
;===============
DELPAOC(X,DA) ;Delete field post action on change.
N IENS
I X=1 S IENS=$$IENS^DILF(.DA),^TMP($J,"UNLINK",9999999.09,IENS)=""
Q
;
;===============
DELPRE ;Delete field pre-action.
N TEXT
S TEXT(1)="Enter 'Y' if you want to delete this code mapping."
S TEXT(2)="Warning - a deletion will remove all mapped source entries created"
S TEXT(3)="as a result of this code mapping."
D EN^DDIOL(.TEXT)
Q
;
;===============
FDATAVAL(IEN) ;Form Data Validation.
N CLASS,MAX,MAXDEC,MIN,NAME,PREFIX,PROMPT
N SCLASS,SIEN,UCUM,UDISPLAY,TEXT
;Validate measurement input.
S MIN=$$GET^DDSVAL(9999999.09,IEN,220)
S MAX=$$GET^DDSVAL(9999999.09,IEN,221)
S MAXDEC=$$GET^DDSVAL(9999999.09,IEN,222)
S UCUM=$$GET^DDSVAL(9999999.09,IEN,223)
S PROMPT=$$GET^DDSVAL(9999999.09,IEN,224)
S UDISPLAY=$$GET^DDSVAL(9999999.09,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 Education
;Topic.
S CLASS=$$GET^DDSVAL(9999999.09,IEN,100,.ERROR,"I")
S SIEN=$$GET^DDSVAL(9999999.09,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_", Education Topic 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 and vice versa.
S NAME=$$GET^DDSVAL(9999999.09,IEN,.01)
S PREFIX=$E(NAME,1,3),TEXT=""
I PREFIX="VA-",CLASS'="N" S TEXT="Name starts with 'VA-', but the Class is not National."
I CLASS="N",PREFIX'="VA-" S TEXT="The Class is National but the name does not start with VA-."
I TEXT'="" D
. D HLP^DDSUTL(.TEXT)
. S DDSBR="NAME",DDSERROR=1
Q
;
;===============
FPOSTACT(IEN) ;Form Post-Action
N INACTIVE,INUSE,OUTPUT
;If the change was a deletion there is nothing else to do.
I '$D(^AUTTEDT(IEN)) Q
;If the exam was inactivated check to see if it is being used.
;Need a new FileMan API to do this.
S INACTIVE=$$GET^DDSVAL(9999999.09,IEN,"INACTIVE FLAG")
Q
;
;===============
FPOSTSAV(IEN) ;Form Post-Save.
;Check for mapped codes to link.
D MCLINK^PXMCLINK(9999999.09,IEN)
;Check for mappings to delete and unlink.
I $D(^TMP($J,"UNLINK",9999999.09)) D MCUNLINK^PXMCLINK(9999999.09,IEN)
Q
;
;===============
FPREACT(DA) ;Form pre-action
Q
;
;===============
LINKED(DA) ;Date Linked executable caption. This is really the display
;for the Linked column, the field is uneditable.
I DA="" Q " "
N LINKDT
S LINKDT=$$GET^DDSVAL(9999999.11,.DA,"DATE LINKED")
Q $S(LINKDT'="":"Y",1:"N")
;
;===============
MCBLKPRE(DA) ;Mapped codes block pre-action.
;Make any mapped codes uneditable.
N IENS,IND
S IEN=DA(1),IND=0
F S IND=+$O(^AUTTEDT(IEN,210,IND)) Q:IND=0 D
. I $P(^AUTTEDT(IEN,210,IND,0),U,2)="" Q
. S IENS=IND_","_IEN_","
. D UNED^DDSUTL("CODING SYSTEM","PX EDU CODE MAPPINGS BLOCK",1,1,IENS)
. D UNED^DDSUTL("CODE","PX EDU CODE MAPPINGS BLOCK",1,1,IENS)
. D UNED^DDSUTL("DELETE","PX EDU CODE MAPPINGS BLOCK",1,0,IENS)
Q
;
;===============
SMANEDIT(IEN,NEW) ;ScreenMan edit for entry IEN.
N CLASS,CODEMAP,DA,DDSCHANG,DDSFILE,DDSPARM,DDSSAVE,DEL,DIDEL,DIMSG,DR,DTOUT
N HASH256,OCLOG,NATOK,SHASH256
S CLASS=$$GET^DDSVAL(9999999.09,IEN,100,.ERROR,"I")
S NATOK=$S(CLASS'="N":1,1:($G(PXNAT)=1)&($G(DUZ(0))="@"))
I 'NATOK D Q
. W !,"National education topics cannot be edited."
. H 2
. S VALMBCK="R"
S (DDSFILE,DIDEL)=9999999.09,DDSPARM="CS"
S CODEMAP=$S((CLASS="N")&$D(^XUSEC("PX CODE MAPPING",DUZ)):1,1:0)
S DR=$S(CODEMAP=1:"[PX EDUCATION TOPIC EDIT]",1:"[PX EDUCATION TOPIC EDIT NCM]")
S NEW=$G(NEW)
S SHASH256=$$FILE^XLFSHAN(256,9999999.09,IEN)
S DA=IEN
D ^DDS
I $D(DIMSG) H 2
;If the entry is new and the user did not save, delete it.
I NEW,$G(DDSSAVE)'=1 D DELFE^PXUTIL(9999999.09,IEN) Q
;If changes were made update the change log. If the change was a
;deletion skip the change log.
S DEL=$S($D(^AUTTEDT(IEN)):0,1:1)
I DEL D Q
. D BLDLIST^PXEDUMGR("PXEDUL")
. S VALMBCK="R"
I NEW S OCLOG=1
E S HASH256=$$FILE^XLFSHAN(256,9999999.09,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(9999999.1,IENS,.01)=$$NOW^XLFDT
S FDA(9999999.1,IENS,1)=DUZ
I NEW D
. S WPTMP(1,1,1)=" Creation."
. S FDA(9999999.1,IENS,2)="WPTMP(1,1)"
D UPDATE^DIE("S","FDA","FDAIEN","MSG")
K DA,DDSFILE
S DA=FDAIEN(1),DA(1)=IEN
S DDSFILE=9999999.09,DDSFILE(1)=9999999.1
S DR="[PX EDUCATION TOPIC CHANGE LOG]"
D ^DDS
D BLDLIST^PXEDUMGR("PXEDUL") S VALMBCK="R"
Q
;
;===============
STEXCAP(DA) ;Subtopics executable caption.
N NSUBTOP,TEXT
S NSUBTOP=+$P($G(^AUTTEDT(DA,10,0)),U,4)
S TEXT="SUBTOPICS: "
I NSUBTOP=0 S TEXT=TEXT_"None defined" Q TEXT
I NSUBTOP=1 S TEXT=TEXT_"There is 1 subtopic" Q TEXT
I NSUBTOP>1 S TEXT=TEXT_"There are "_NSUBTOP_" subtopics"
Q TEXT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXEDUSM 6488 printed Dec 13, 2024@02:28:48 Page 2
PXEDUSM ;SLC/PKR - Education Topics ScreenMan routines ;06/14/2022
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**211,217**;Aug 12, 1996;Build 134
+2 ;
+3 ;===============
CODEPAOC(DA) ;Code Post-Action On Change.
+1 NEW CODE,CODESYS,NEWCODE,SAVEDDS
+2 SET CODESYS=$$GET^DDSVAL(9999999.11,.DA,.01)
+3 SET CODE=$$GET^DDSVAL(9999999.11,.DA,1)
+4 ;DBIA #5746 covers kill and set of DDS.
+5 IF $DATA(DDS)
SET SAVEDDS=DDS
KILL DDS
+6 ;Call the Lexicon search.
+7 SET NEWCODE=$$GETCODE^PXLEXS(CODESYS,CODE,DT,0)
+8 ;Reset the screen so ScreenMan displays properly.
+9 IF $DATA(SAVEDDS)
Begin DoDot:1
+10 NEW IOAWM0,X
+11 SET DDS=SAVEDDS
+12 SET X=0
XECUTE ^%ZOSF("RM")
XECUTE ^%ZOSF("TYPE-AHEAD")
+13 SET X="IOAWM0"
DO ENDR^%ZISS
WRITE IOAWM0
+14 DO REFRESH^DDSUTL
End DoDot:1
+15 DO PUT^DDSVAL(9999999.11,.DA,1,NEWCODE)
+16 QUIT
+17 ;
+18 ;===============
CODEPRE(DA) ;Code pre-action.
+1 NEW CODESYS,TEXT
+2 SET CODESYS=$$GET^DDSVAL(9999999.11,.DA,.01)
+3 ;ICR #5679
+4 SET CODESYS=$PIECE($$CSYS^LEXU(CODESYS),U,4)
+5 SET TEXT(1)="Input a search term or a "_CODESYS_" code."
+6 DO EN^DDIOL(.TEXT)
+7 QUIT
+8 ;
+9 ;===============
DELPAOC(X,DA) ;Delete field post action on change.
+1 NEW IENS
+2 IF X=1
SET IENS=$$IENS^DILF(.DA)
SET ^TMP($JOB,"UNLINK",9999999.09,IENS)=""
+3 QUIT
+4 ;
+5 ;===============
DELPRE ;Delete field pre-action.
+1 NEW TEXT
+2 SET TEXT(1)="Enter 'Y' if you want to delete this code mapping."
+3 SET TEXT(2)="Warning - a deletion will remove all mapped source entries created"
+4 SET TEXT(3)="as a result of this code mapping."
+5 DO EN^DDIOL(.TEXT)
+6 QUIT
+7 ;
+8 ;===============
FDATAVAL(IEN) ;Form Data Validation.
+1 NEW CLASS,MAX,MAXDEC,MIN,NAME,PREFIX,PROMPT
+2 NEW SCLASS,SIEN,UCUM,UDISPLAY,TEXT
+3 ;Validate measurement input.
+4 SET MIN=$$GET^DDSVAL(9999999.09,IEN,220)
+5 SET MAX=$$GET^DDSVAL(9999999.09,IEN,221)
+6 SET MAXDEC=$$GET^DDSVAL(9999999.09,IEN,222)
+7 SET UCUM=$$GET^DDSVAL(9999999.09,IEN,223)
+8 SET PROMPT=$$GET^DDSVAL(9999999.09,IEN,224)
+9 SET UDISPLAY=$$GET^DDSVAL(9999999.09,IEN,225)
+10 IF (MIN="")
IF (MAX="")
IF (MAXDEC="")
IF (UCUM="")
IF (PROMPT="")
IF (UDISPLAY="")
GOTO SPONCLASS
+11 ;If any of the measurement fields are defined they all must be.
+12 IF (MIN="")!(MAX="")!(MAXDEC="")!(UCUM="")!(PROMPT="")!(UDISPLAY="")
Begin DoDot:1
+13 SET TEXT="If any of the measurement fields are defined, they all must be."
+14 DO HLP^DDSUTL(.TEXT)
+15 SET DDSBR="MINIMUM VALUE"
SET DDSERROR=1
End DoDot:1
QUIT
+16 IF MAX<MIN
Begin DoDot:1
+17 SET TEXT="The Maximum Value cannot be less than the Minimum Value."
+18 DO HLP^DDSUTL(.TEXT)
+19 SET DDSBR="MAXIMUM VALUE"
SET DDSERROR=1
End DoDot:1
QUIT
SPONCLASS ;Make sure the Class of the Sponsor matches that of the Education
+1 ;Topic.
+2 SET CLASS=$$GET^DDSVAL(9999999.09,IEN,100,.ERROR,"I")
+3 SET SIEN=$$GET^DDSVAL(9999999.09,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_", Education Topic 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 and vice versa.
+10 SET NAME=$$GET^DDSVAL(9999999.09,IEN,.01)
+11 SET PREFIX=$EXTRACT(NAME,1,3)
SET TEXT=""
+12 IF PREFIX="VA-"
IF CLASS'="N"
SET TEXT="Name starts with 'VA-', but the Class is not National."
+13 IF CLASS="N"
IF PREFIX'="VA-"
SET TEXT="The Class is National but the name does not start with VA-."
+14 IF TEXT'=""
Begin DoDot:1
+15 DO HLP^DDSUTL(.TEXT)
+16 SET DDSBR="NAME"
SET DDSERROR=1
End DoDot:1
+17 QUIT
+18 ;
+19 ;===============
FPOSTACT(IEN) ;Form Post-Action
+1 NEW INACTIVE,INUSE,OUTPUT
+2 ;If the change was a deletion there is nothing else to do.
+3 IF '$DATA(^AUTTEDT(IEN))
QUIT
+4 ;If the exam was inactivated check to see if it is being used.
+5 ;Need a new FileMan API to do this.
+6 SET INACTIVE=$$GET^DDSVAL(9999999.09,IEN,"INACTIVE FLAG")
+7 QUIT
+8 ;
+9 ;===============
FPOSTSAV(IEN) ;Form Post-Save.
+1 ;Check for mapped codes to link.
+2 DO MCLINK^PXMCLINK(9999999.09,IEN)
+3 ;Check for mappings to delete and unlink.
+4 IF $DATA(^TMP($JOB,"UNLINK",9999999.09))
DO MCUNLINK^PXMCLINK(9999999.09,IEN)
+5 QUIT
+6 ;
+7 ;===============
FPREACT(DA) ;Form pre-action
+1 QUIT
+2 ;
+3 ;===============
LINKED(DA) ;Date Linked executable caption. This is really the display
+1 ;for the Linked column, the field is uneditable.
+2 IF DA=""
QUIT " "
+3 NEW LINKDT
+4 SET LINKDT=$$GET^DDSVAL(9999999.11,.DA,"DATE LINKED")
+5 QUIT $SELECT(LINKDT'="":"Y",1:"N")
+6 ;
+7 ;===============
MCBLKPRE(DA) ;Mapped codes block pre-action.
+1 ;Make any mapped codes uneditable.
+2 NEW IENS,IND
+3 SET IEN=DA(1)
SET IND=0
+4 FOR
SET IND=+$ORDER(^AUTTEDT(IEN,210,IND))
if IND=0
QUIT
Begin DoDot:1
+5 IF $PIECE(^AUTTEDT(IEN,210,IND,0),U,2)=""
QUIT
+6 SET IENS=IND_","_IEN_","
+7 DO UNED^DDSUTL("CODING SYSTEM","PX EDU CODE MAPPINGS BLOCK",1,1,IENS)
+8 DO UNED^DDSUTL("CODE","PX EDU CODE MAPPINGS BLOCK",1,1,IENS)
+9 DO UNED^DDSUTL("DELETE","PX EDU CODE MAPPINGS BLOCK",1,0,IENS)
End DoDot:1
+10 QUIT
+11 ;
+12 ;===============
SMANEDIT(IEN,NEW) ;ScreenMan edit for entry IEN.
+1 NEW CLASS,CODEMAP,DA,DDSCHANG,DDSFILE,DDSPARM,DDSSAVE,DEL,DIDEL,DIMSG,DR,DTOUT
+2 NEW HASH256,OCLOG,NATOK,SHASH256
+3 SET CLASS=$$GET^DDSVAL(9999999.09,IEN,100,.ERROR,"I")
+4 SET NATOK=$SELECT(CLASS'="N":1,1:($GET(PXNAT)=1)&($GET(DUZ(0))="@"))
+5 IF 'NATOK
Begin DoDot:1
+6 WRITE !,"National education topics cannot be edited."
+7 HANG 2
+8 SET VALMBCK="R"
End DoDot:1
QUIT
+9 SET (DDSFILE,DIDEL)=9999999.09
SET DDSPARM="CS"
+10 SET CODEMAP=$SELECT((CLASS="N")&$DATA(^XUSEC("PX CODE MAPPING",DUZ)):1,1:0)
+11 SET DR=$SELECT(CODEMAP=1:"[PX EDUCATION TOPIC EDIT]",1:"[PX EDUCATION TOPIC EDIT NCM]")
+12 SET NEW=$GET(NEW)
+13 SET SHASH256=$$FILE^XLFSHAN(256,9999999.09,IEN)
+14 SET DA=IEN
+15 DO ^DDS
+16 IF $DATA(DIMSG)
HANG 2
+17 ;If the entry is new and the user did not save, delete it.
+18 IF NEW
IF $GET(DDSSAVE)'=1
DO DELFE^PXUTIL(9999999.09,IEN)
QUIT
+19 ;If changes were made update the change log. If the change was a
+20 ;deletion skip the change log.
+21 SET DEL=$SELECT($DATA(^AUTTEDT(IEN)):0,1:1)
+22 IF DEL
Begin DoDot:1
+23 DO BLDLIST^PXEDUMGR("PXEDUL")
+24 SET VALMBCK="R"
End DoDot:1
QUIT
+25 IF NEW
SET OCLOG=1
+26 IF '$TEST
SET HASH256=$$FILE^XLFSHAN(256,9999999.09,IEN)
SET OCLOG=$SELECT(HASH256=SHASH256:0,1:1)
+27 IF 'OCLOG
SET VALMBCK="R"
QUIT
+28 ;Open the Change Log
+29 NEW IENS,FDA,FDAIEN,MSG,WPTMP
+30 SET IENS="+1,"_IEN_","
+31 SET FDA(9999999.1,IENS,.01)=$$NOW^XLFDT
+32 SET FDA(9999999.1,IENS,1)=DUZ
+33 IF NEW
Begin DoDot:1
+34 SET WPTMP(1,1,1)=" Creation."
+35 SET FDA(9999999.1,IENS,2)="WPTMP(1,1)"
End DoDot:1
+36 DO UPDATE^DIE("S","FDA","FDAIEN","MSG")
+37 KILL DA,DDSFILE
+38 SET DA=FDAIEN(1)
SET DA(1)=IEN
+39 SET DDSFILE=9999999.09
SET DDSFILE(1)=9999999.1
+40 SET DR="[PX EDUCATION TOPIC CHANGE LOG]"
+41 DO ^DDS
+42 DO BLDLIST^PXEDUMGR("PXEDUL")
SET VALMBCK="R"
+43 QUIT
+44 ;
+45 ;===============
STEXCAP(DA) ;Subtopics executable caption.
+1 NEW NSUBTOP,TEXT
+2 SET NSUBTOP=+$PIECE($GET(^AUTTEDT(DA,10,0)),U,4)
+3 SET TEXT="SUBTOPICS: "
+4 IF NSUBTOP=0
SET TEXT=TEXT_"None defined"
QUIT TEXT
+5 IF NSUBTOP=1
SET TEXT=TEXT_"There is 1 subtopic"
QUIT TEXT
+6 IF NSUBTOP>1
SET TEXT=TEXT_"There are "_NSUBTOP_" subtopics"
+7 QUIT TEXT
+8 ;
