PXEXSM ;SLC/PKR - Exam 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,IENS,NEWCODE,OLDCODE,SAVEDDS
S IENS=$$IENS^DILF(.DA)
S OLDCODE=$$GET1^DIQ(9999999.18,IENS,1)
S CODESYS=$$GET^DDSVAL(9999999.18,.DA,.01)
S CODE=$$GET^DDSVAL(9999999.18,.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
S CODE=$S(NEWCODE'="":NEWCODE,1:OLDCODE)
D PUT^DDSVAL(9999999.18,.DA,1,CODE)
Q
;
;===================================
CODEPRE(DA) ;Code pre-action.
N CODESYS,TEXT
S CODESYS=$$GET^DDSVAL(9999999.18,.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.15,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,ERROR,MAX,MAXDEC,MIN,NAME,PREFIX,PROMPT
N SCLASS,SIEN,UCUM,UDISPLAY,TEXT
;Validate measurement input.
S MIN=$$GET^DDSVAL(9999999.15,IEN,220)
S MAX=$$GET^DDSVAL(9999999.15,IEN,221)
S MAXDEC=$$GET^DDSVAL(9999999.15,IEN,222)
S UCUM=$$GET^DDSVAL(9999999.15,IEN,223)
S PROMPT=$$GET^DDSVAL(9999999.15,IEN,224)
S UDISPLAY=$$GET^DDSVAL(9999999.15,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 Exam.
S CLASS=$$GET^DDSVAL(9999999.15,IEN,100,.ERROR,"I")
S SIEN=$$GET^DDSVAL(9999999.15,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_", Exam 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.15,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(^AUTTEXAM(D0)) 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.15,IEN,"INACTIVE FLAG")
Q
;
;===================================
FPOSTSAV(IEN) ;Form Post-Save.
;Check for mapped codes to link.
D MCLINK^PXMCLINK(9999999.15,IEN)
;Check for mappings to delete and unlink.
I $D(^TMP($J,"UNLINK",9999999.15)) D MCUNLINK^PXMCLINK(9999999.15,IEN)
Q
;
;===================================
FPREACT(DA) ;Form pre-action
Q
;
;===================================
LINKED(DA) ;This is the display for the Linked column,
;the field is uneditable.
I DA="" Q " "
N LINKDT
S LINKDT=$$GET^DDSVAL(9999999.18,.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(^AUTTEXAM(IEN,210,IND)) Q:IND=0 D
. I $P(^AUTTEXAM(IEN,210,IND,0),U,2)="" Q
. S IENS=IND_","_IEN_","
. D UNED^DDSUTL("CODING SYSTEM","PX EXAM CODE MAPPINGS BLOCK",1,1,IENS)
. D UNED^DDSUTL("CODE","PX EXAM CODE MAPPINGS BLOCK",1,1,IENS)
. D UNED^DDSUTL("DELETE","PX EXAM 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.15,IEN,100,.ERROR,"I")
S NATOK=$S(CLASS'="N":1,1:($G(PXNAT)=1)&($G(DUZ(0))="@"))
I 'NATOK D Q
. W !,"National exams cannot be edited."
. H 2
. S VALMBCK="R"
S (DDSFILE,DIDEL)=9999999.15,DDSPARM="CS"
S CODEMAP=$S((CLASS="N")&$D(^XUSEC("PX CODE MAPPING",DUZ)):1,1:0)
S DR=$S(CODEMAP=1:"[PX EXAM EDIT]",1:"[PX EXAM EDIT NCM]")
S NEW=$G(NEW)
S SHASH256=$$FILE^XLFSHAN(256,9999999.15,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.15,IEN) Q
;If changes were made update the change log. If the change was a
;deletion skip the change log.
S DEL=$S($D(^AUTTEXAM(IEN)):0,1:1)
I DEL D Q
. D BLDLIST^PXEXMGR("PXEXAML")
. S VALMBCK="R"
I NEW S OCLOG=1
E S HASH256=$$FILE^XLFSHAN(256,9999999.15,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.16,IENS,.01)=$$NOW^XLFDT
S FDA(9999999.16,IENS,1)=DUZ
I NEW D
. S WPTMP(1,1,1)=" Creation."
. S FDA(9999999.16,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.15,DDSFILE(1)=9999999.16
S DR="[PX EXAM CHANGE LOG]"
D ^DDS
D BLDLIST^PXEXMGR("PXEXAML") S VALMBCK="R"
Q
;
;===================================
UNLINK(X,DA) ;Unlink form-only field save code.
N IENS
I X=1 S IENS=$$IENS^DILF(.DA),^TMP($J,"UNLINK",9999999.15,IENS)=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXEXSM 6576 printed Dec 13, 2024@02:28:51 Page 2
PXEXSM ;SLC/PKR - Exam 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,IENS,NEWCODE,OLDCODE,SAVEDDS
+2 SET IENS=$$IENS^DILF(.DA)
+3 SET OLDCODE=$$GET1^DIQ(9999999.18,IENS,1)
+4 SET CODESYS=$$GET^DDSVAL(9999999.18,.DA,.01)
+5 SET CODE=$$GET^DDSVAL(9999999.18,.DA,1)
+6 ;DBIA #5746 covers kill and set of DDS.
+7 IF $DATA(DDS)
SET SAVEDDS=DDS
KILL DDS
+8 ;Call the Lexicon search.
+9 SET NEWCODE=$$GETCODE^PXLEXS(CODESYS,CODE,DT,0)
+10 ;Reset the screen so ScreenMan displays properly.
+11 IF $DATA(SAVEDDS)
Begin DoDot:1
+12 NEW IOAWM0,X
+13 SET DDS=SAVEDDS
+14 SET X=0
XECUTE ^%ZOSF("RM")
XECUTE ^%ZOSF("TYPE-AHEAD")
+15 SET X="IOAWM0"
DO ENDR^%ZISS
WRITE IOAWM0
+16 DO REFRESH^DDSUTL
End DoDot:1
+17 SET CODE=$SELECT(NEWCODE'="":NEWCODE,1:OLDCODE)
+18 DO PUT^DDSVAL(9999999.18,.DA,1,CODE)
+19 QUIT
+20 ;
+21 ;===================================
CODEPRE(DA) ;Code pre-action.
+1 NEW CODESYS,TEXT
+2 SET CODESYS=$$GET^DDSVAL(9999999.18,.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.15,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,ERROR,MAX,MAXDEC,MIN,NAME,PREFIX,PROMPT
+2 NEW SCLASS,SIEN,UCUM,UDISPLAY,TEXT
+3 ;Validate measurement input.
+4 SET MIN=$$GET^DDSVAL(9999999.15,IEN,220)
+5 SET MAX=$$GET^DDSVAL(9999999.15,IEN,221)
+6 SET MAXDEC=$$GET^DDSVAL(9999999.15,IEN,222)
+7 SET UCUM=$$GET^DDSVAL(9999999.15,IEN,223)
+8 SET PROMPT=$$GET^DDSVAL(9999999.15,IEN,224)
+9 SET UDISPLAY=$$GET^DDSVAL(9999999.15,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 Exam.
+1 SET CLASS=$$GET^DDSVAL(9999999.15,IEN,100,.ERROR,"I")
+2 SET SIEN=$$GET^DDSVAL(9999999.15,IEN,101,.ERROR,"I")
+3 SET SCLASS=$SELECT(SIEN="":"",1:$$GET1^DIQ(811.6,SIEN,100,"I"))
+4 IF (SCLASS'="")
IF (SCLASS'=CLASS)
Begin DoDot:1
+5 SET TEXT="Sponsor Class is "_SCLASS_", Exam Class is "_CLASS_" they must match!"
+6 DO HLP^DDSUTL(.TEXT)
+7 SET DDSBR="CLASS"
SET DDSERROR=1
End DoDot:1
+8 ;If the Name starts with VA- make sure the Class is National and vice versa.
+9 SET NAME=$$GET^DDSVAL(9999999.15,IEN,.01)
+10 SET PREFIX=$EXTRACT(NAME,1,3)
SET TEXT=""
+11 IF PREFIX="VA-"
IF CLASS'="N"
SET TEXT="Name starts with 'VA-', but the Class is not National."
+12 IF CLASS="N"
IF PREFIX'="VA-"
SET TEXT="The Class is National but the name does not start with VA-."
+13 IF TEXT'=""
Begin DoDot:1
+14 DO HLP^DDSUTL(.TEXT)
+15 SET DDSBR="NAME"
SET DDSERROR=1
End DoDot:1
+16 QUIT
+17 ;
+18 ;===================================
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(^AUTTEXAM(D0))
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.15,IEN,"INACTIVE FLAG")
+7 QUIT
+8 ;
+9 ;===================================
FPOSTSAV(IEN) ;Form Post-Save.
+1 ;Check for mapped codes to link.
+2 DO MCLINK^PXMCLINK(9999999.15,IEN)
+3 ;Check for mappings to delete and unlink.
+4 IF $DATA(^TMP($JOB,"UNLINK",9999999.15))
DO MCUNLINK^PXMCLINK(9999999.15,IEN)
+5 QUIT
+6 ;
+7 ;===================================
FPREACT(DA) ;Form pre-action
+1 QUIT
+2 ;
+3 ;===================================
LINKED(DA) ;This is the display for the Linked column,
+1 ;the field is uneditable.
+2 IF DA=""
QUIT " "
+3 NEW LINKDT
+4 SET LINKDT=$$GET^DDSVAL(9999999.18,.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(^AUTTEXAM(IEN,210,IND))
if IND=0
QUIT
Begin DoDot:1
+5 IF $PIECE(^AUTTEXAM(IEN,210,IND,0),U,2)=""
QUIT
+6 SET IENS=IND_","_IEN_","
+7 DO UNED^DDSUTL("CODING SYSTEM","PX EXAM CODE MAPPINGS BLOCK",1,1,IENS)
+8 DO UNED^DDSUTL("CODE","PX EXAM CODE MAPPINGS BLOCK",1,1,IENS)
+9 DO UNED^DDSUTL("DELETE","PX EXAM 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.15,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 exams cannot be edited."
+7 HANG 2
+8 SET VALMBCK="R"
End DoDot:1
QUIT
+9 SET (DDSFILE,DIDEL)=9999999.15
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 EXAM EDIT]",1:"[PX EXAM EDIT NCM]")
+12 SET NEW=$GET(NEW)
+13 SET SHASH256=$$FILE^XLFSHAN(256,9999999.15,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.15,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(^AUTTEXAM(IEN)):0,1:1)
+22 IF DEL
Begin DoDot:1
+23 DO BLDLIST^PXEXMGR("PXEXAML")
+24 SET VALMBCK="R"
End DoDot:1
QUIT
+25 IF NEW
SET OCLOG=1
+26 IF '$TEST
SET HASH256=$$FILE^XLFSHAN(256,9999999.15,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.16,IENS,.01)=$$NOW^XLFDT
+32 SET FDA(9999999.16,IENS,1)=DUZ
+33 IF NEW
Begin DoDot:1
+34 SET WPTMP(1,1,1)=" Creation."
+35 SET FDA(9999999.16,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.15
SET DDSFILE(1)=9999999.16
+40 SET DR="[PX EXAM CHANGE LOG]"
+41 DO ^DDS
+42 DO BLDLIST^PXEXMGR("PXEXAML")
SET VALMBCK="R"
+43 QUIT
+44 ;
+45 ;===================================
UNLINK(X,DA) ;Unlink form-only field save code.
+1 NEW IENS
+2 IF X=1
SET IENS=$$IENS^DILF(.DA)
SET ^TMP($JOB,"UNLINK",9999999.15,IENS)=""
+3 QUIT
+4 ;
