- 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 Jan 18, 2025@03:29: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 ;