PSOSPMA3 ;BIRM/MFR - ASAP Definitions Listman Actions Handler ;11/11/15
;;7.0;OUTPATIENT PHARMACY;**451,625**;DEC 1997;Build 42
;
SHOWHID ; Handles Show/Hide Details
; (PSOSHOW: 1: Show Segment Tree only; 2: Show Segments & Data Elements; 3: Show Data Element Details)
S VALMBCK="R"
I PSOASVER="1995" D Q
. S VALMSG="Details not available for ASAP 1995 version" W $C(7)
W ?52,"Please wait..." S PSOSHOW=(($G(PSOSHOW)+1)#3)
D INIT^PSOSPML3,HDR^PSOSPML3 I PSOSHOW=0 S VALMBG=1
Q
;
COPYVER ; Handles 'Copy ASAP Version' Action
N NEWASVER,DIR,DIRUT,DTOUT,Y,X,VERS,DEFTYPE
I PSOASVER="1995" S VALMSG="ASAP 1995 Version cannot be copied" W $C(7) G EXIT
I '$$SECKEY() G EXIT
I '$$LOCK() G EXIT
D FULL^VALM1
I PSOASVER="1995" D G BACK
. S VALMSG="ASAP 1995 Version cannot be copied" W $C(7)
CV ; Loop Prompt
W !!," From ASAP Version: ",PSOASVER,!
S DIR(0)="58.4001,.01",DIR("A")=" To ASAP Version" D ^DIR I $D(DIRUT)!$D(DTOUT) G BACK
D VERLIST^PSOSPMU0("A","B",.VERS) ;adding "B" for Zero Report
I $D(VERS(Y_" ")) W !!?3,"ASAP Version '",Y,"' already exists.",$C(7) G CV
S NEWASVER=Y
S X="",DEFTYPE="B"
I $G(VERS(PSOASVER_" "))="C" D I X="^" G BACK
. W ! S X=$$ASKFLD("Y","YES","Copy Customizations") I X="^" Q
. S DEFTYPE=$S(X=1:"B",1:"S")
W ! S X=$$ASKFLD("Y","NO","Confirm Copy") I X'=1 G BACK
W ?40,"Copying..." D CLONEVER^PSOSPMU3(PSOASVER,NEWASVER,DEFTYPE) H 1 W "Done.",$C(7)
S PSOASVER=NEWASVER
G BACK
;
EDTDELIM ; Handles the 'Edit Delimiters' Action
N ELMDELIM,SEGDELIM,EOSCHR,X,DONE
I PSOASVER="1995" S VALMSG="Delimiters cannot be changed for ASAP 1995 Version" W $C(7) G EXIT
I '$$SECKEY() G EXIT
I '$$LOCK() G EXIT
D FULL^VALM1
W !!,"ASAP Version ",PSOASVER," delimiters: ",!
D LOADASAP^PSOSPMU0(PSOASVER,"B",.ALLASAP) ; Both ASAP Definitions
; Data Element Delimiter
S DONE=0,ELMDELIM=$P($G(ALLASAP),"^",2)
F S X=$$ASKFLD("58.4001,.02",ELMDELIM) Q:X="^" D I DONE Q
. S ELMDELIM=$S(X="@":"",1:X) I X="@" W ?50,"Deleted." Q
. S DONE=1
; Segment Terminator
S DONE=0,SEGDELIM=$P($G(ALLASAP),"^",3)
F S X=$$ASKFLD("58.4001,.03",SEGDELIM) Q:X="^" D I DONE Q
. S SEGDELIM=$S(X="@":"",1:X) I X="@" W ?50,"Deleted." Q
. S DONE=1
I X="^" G BACK
; End-Of-Segment
S DONE=0,EOSCHR=$P($G(ALLASAP),"^",4)
F S X=$$ASKFLD("58.4001,.04",EOSCHR) Q:X="^" D I DONE Q
. I X'="",X'="@",$$UP^XLFSTR(X)'?1"$C("1.3N.(1","1.3N)1")" D Q
. . W !,"Invalid format. Use $C to specify a character escape sequence.",$C(7),!
. S EOSCHR=$S(X="@":"",1:X) I X="@" W ?50,"Deleted." Q
. S DONE=1
I X="^" G BACK
; No changes
I $P($G(ALLASAP),"^",2,4)=(ELMDELIM_"^"_SEGDELIM_"^"_EOSCHR) G BACK
;
W ! S X=$$ASKFLD("Y","YES","Save Changes") I X'=1 G BACK
W ?40,"Saving..."
S $P(ALLASAP,"^",2,4)=ELMDELIM_"^"_SEGDELIM_"^"_EOSCHR
D SAVEVER^PSOSPMU3(PSOASVER,ALLASAP)
H 1 W "OK",$C(7)
G BACK
;
CUSSEG ; Handles the 'Customize Segment' Action
N CUSSEG,DIR,DIRUT,DTOUT,X,Y,STDASAP,CUSASAP,ALLASAP,NEWSEG,DONE,QUIT,SEG,OK,SEGREQ,SEGPOS,PARSEG
N HLPTXT,CUSSEGS,CNT,LITERAL
I PSOASVER="1995" S VALMSG="ASAP 1995 Version cannot be customized" W $C(7) G EXIT
I '$$SECKEY() G EXIT
I '$$LOCK() G EXIT
D FULL^VALM1
;
CSL ; Loop Re-Prompt
D LOADASAP^PSOSPMU0(PSOASVER,"S",.STDASAP) ; Standard ASAP Definition
D LOADASAP^PSOSPMU0(PSOASVER,"C",.CUSASAP) ; Custom ASAP Definition
D LOADASAP^PSOSPMU0(PSOASVER,"B",.ALLASAP) ; Both ASAP Definitions
;
CSE ; Error Re-Prompt
K DIR S HLPTXT="Enter the ASAP Segment ID that you want to customize (e.g.,'AIR')."
I $G(STDASAP)'="" D
. S SEG="999" F S SEG=$O(CUSASAP(SEG)) Q:SEG="" D
. . I $$CUSSEG^PSOSPMU3(PSOASVER,SEG) S CUSSEGS(SEG)=$P(CUSASAP(SEG),"^",2)
I '$D(CUSSEGS) D
. S DIR("?")=HLPTXT
E D
. S DIR("?",1)=HLPTXT,(DIR("?"),DIR("?",2))=" "
. S SEG="",CNT=3 F S SEG=$O(CUSSEGS(SEG)) Q:SEG="" D
. . I $O(CUSSEGS(SEG))="" S DIR("?")=SEG_" "_$P(CUSSEGS(SEG),"^") Q
. . S DIR("?",CNT)=SEG_" "_$P(CUSSEGS(SEG),"^"),CNT=CNT+1
S DIR(0)="FO^1:5",DIR("A")="SEGMENT ID"
W ! D ^DIR I $D(DIRUT)!$D(DTOUT)!(X="") G BACK
S LITERAL=0 I $E(X)="""",$E(X,$L(X))="""" S X=$E(X,2,$L(X)-1),LITERAL=1
I (X'?.AN)!($E(X,$L(X))?1N)!(X[" ") W !,"Invalid Segment ID.",$C(7) G CSE
I 'LITERAL,'$D(ALLASAP(X)),$D(ALLASAP($$UP^XLFSTR(X))) S X=$$UP^XLFSTR(X)
S CUSSEG=X W " ",$P($G(ALLASAP(CUSSEG)),"^",2) W !
I $D(STDASAP(CUSSEG)) D
. ; Segment Requirement
. S X=$$ASKFLD("58.40011,.04",$P($G(ALLASAP(CUSSEG)),"^",4)) I X="^" Q
. S SEGREQ=X
. W ! S X=$$ASKFLD("Y","YES","Save Custom Segment") I X'=1 Q
. W ?40,"Saving..."
. ; If first time the Segment is being customized, copy; otherwise save
. I '$D(CUSASAP(CUSSEG)) D
. . S $P(STDASAP(CUSSEG),"^",4)=SEGREQ
. . D COPYSEG^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,CUSSEG)
. E D
. . S $P(CUSASAP(CUSSEG),"^",4)=SEGREQ
. . D SAVESEG^PSOSPMU3(PSOASVER,CUSSEG,CUSASAP(CUSSEG),ALLASAP)
. W "OK",$C(7)
E D
. S (Y,NEWSEG)=0
. I '$D(CUSASAP(CUSSEG)) D I $D(DIRUT)!$D(DTOUT)!'Y Q
. . K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you adding '"_CUSSEG_"' as a new SEGMENT ID" W $C(7) D ^DIR
. . S NEWSEG=1 W !
. S $P(CUSASAP(CUSSEG),"^",1)=CUSSEG
. ; Segment Name
. S X=$$ASKFLD("58.40011,.02",$P(CUSASAP(CUSSEG),"^",2)) I X="^" Q
. S $P(CUSASAP(CUSSEG),"^",2)=X
. ; Parent Segment
. S DONE=0
. F S X=$$ASKFLD("58.40011,.03",$P(CUSASAP(CUSSEG),"^",3)) Q:X="^"!(X="") D I DONE Q
. . I X="@" S $P(CUSASAP(CUSSEG),"^",3)="" Q
. . I '$D(ALLASAP(X)),$D(ALLASAP($$UP^XLFSTR(X))) S X=$$UP^XLFSTR(X)
. . I '$D(ALLASAP(X)) W !,"Parent Segment ID not found.",$C(7) Q
. . I X=CUSSEG W !,"Parent Segment ID cannot be its own parent.",$C(7) Q
. . W " ",$P(ALLASAP(X),"^",2)
. . S $P(CUSASAP(CUSSEG),"^",3)=X,DONE=1
. I X="^" Q
. ; Segment Requirement
. S X=$$ASKFLD("58.40011,.04",$P(CUSASAP(CUSSEG),"^",4)) I X="^" Q
. S $P(CUSASAP(CUSSEG),"^",4)=X
. S DONE=0
. F S X=$$ASKFLD("58.40011,.05",$P(CUSASAP(CUSSEG),"^",5)) Q:X="^" D I DONE Q
. . S SEG="999",OK=1 F S SEG=$O(ALLASAP(SEG)) Q:SEG="" D I 'OK Q
. . . I SEG'=CUSSEG,$P(ALLASAP(SEG),"^",3)=$P(CUSASAP(CUSSEG),"^",3),$P(ALLASAP(SEG),"^",5)=X D
. . . . S OK=0 W !,"The Segment '",SEG,"' (",$P(ALLASAP(SEG),"^",2),") already occupies this position.",$C(7) Q
. . I OK S $P(CUSASAP(CUSSEG),"^",5)=X,DONE=1
. I X="^" Q
. ; Segment Level
. S DONE=0,PARSEG=$P(CUSASAP(CUSSEG),"^",3)
. I PARSEG'="",$P(CUSASAP(CUSSEG),"^",6)="",$P($G(ALLASAP(PARSEG)),"^",6)>3 D
. . S $P(CUSASAP(CUSSEG),"^",6)=$P($G(ALLASAP(PARSEG)),"^",6)
. F S X=$$ASKFLD("58.40011,.06",$P(CUSASAP(CUSSEG),"^",6)) Q:X="^" D I DONE Q
. . I $P(CUSASAP(CUSSEG),"^",3)="",X'=1,X'=6 D Q
. . . W !,"Orphan segments can only be located at the MAIN HEADER or MAIN TRAILER levels.",$C(7)
. . S QUIT=0
. . I PARSEG'="" D I QUIT Q
. . . I $P($G(ALLASAP(PARSEG)),"^",6)>3,X'=$P($G(ALLASAP(PARSEG)),"^",6) D S QUIT=1 Q
. . . . W !,"Segment level must be the same as the parent's level (",$P($G(ALLASAP(PARSEG)),"^",6),").",$C(7)
. . . I X<$P($G(ALLASAP(PARSEG)),"^",6) D S QUIT=1 Q
. . . . W !,"Segment level cannot be lower than parent's level (",$P($G(ALLASAP(PARSEG)),"^",6),").",$C(7)
. . . I X>($P($G(ALLASAP(PARSEG)),"^",6)+1) D S QUIT=1 Q
. . . . W !,"Segment level cannot be more than 1 level above parent's level (",$P($G(ALLASAP(PARSEG)),"^",6),").",$C(7)
. . S $P(CUSASAP(CUSSEG),"^",6)=X,DONE=1
. I X="^" Q
. ; Confirm
. W ! S X=$$ASKFLD("Y","YES","Save Custom Segment") I X'=1 Q
. W ?40,"Saving..."
. D SAVESEG^PSOSPMU3(PSOASVER,$S(NEWSEG:"+1",1:CUSSEG),CUSASAP(CUSSEG),ALLASAP)
. H 1 W "OK",$C(7)
G CSL
;
CUSELM ; Handles the 'Customize Element' Action
N CUSELM,DIR,DIRUT,DTOUT,X,Y,STDASAP,CUSASAP,SEGID,ELMPOS,MAXLEN,ELMREQ,NEWELM,ELMDATA
N DIC,DWPK,I,MEXPR,LINE,HLPTXT,CUSELMS,CNT,ELM
I PSOASVER="1995" S VALMSG="ASAP 1995 Version cannot be customized" W $C(7) G EXIT
I '$$SECKEY() G EXIT
I '$$LOCK() G EXIT
D FULL^VALM1
;
CEL ; Loop Re-Prompt
D LOADASAP^PSOSPMU0(PSOASVER,"S",.STDASAP) ; Standard ASAP Definition
D LOADASAP^PSOSPMU0(PSOASVER,"C",.CUSASAP) ; Custom ASAP Definition
D LOADASAP^PSOSPMU0(PSOASVER,"B",.ALLASAP) ; Both ASAP Definitions
;
CEE ; Error Re-Prompt
K DIR S HLPTXT="Enter the ASAP Data Element ID that you want to customize (e.g.,'PAT03')"
I $G(STDASAP)'="" D
. S SEG="999" F S SEG=$O(CUSASAP(SEG)) Q:SEG="" D
. . S ELM=0 F S ELM=$O(CUSASAP(SEG,ELM)) Q:'ELM D
. . . S CUSELMS($P(CUSASAP(SEG,ELM),"^"))=$P(CUSASAP(SEG,ELM),"^",2)
I '$D(CUSELMS) D
. S DIR("?")=HLPTXT
E D
. S DIR("?",1)=HLPTXT,(DIR("?"),DIR("?",2))=" "
. S CNT=2,ELM="" F S ELM=$O(CUSELMS(ELM)) Q:ELM="" D
. . I $O(CUSELMS(ELM))="" S DIR("?")=ELM_" "_$P(CUSELMS(ELM),"^") Q
. . S DIR("?",CNT)=ELM_" "_$P(CUSELMS(ELM),"^"),CNT=CNT+1
S DIR(0)="FO^1:10",DIR("A")="DATA ELEMENT ID"
W ! D ^DIR I $D(DIRUT)!$D(DTOUT)!(X="") G BACK
S SEGID=$$GETSEGID^PSOSPMU3(X) I SEGID=""!(X[" ") W !,"Invalid Segment.",$C(7) G CEE
I '$D(ALLASAP(SEGID)),$D(ALLASAP($$UP^XLFSTR(SEGID))) D
. S X=$$UP^XLFSTR(X),SEGID=$$UP^XLFSTR(SEGID)
I '$D(ALLASAP(SEGID)) W !!,"Segment ID '",SEGID,"' not found.",$C(7) G CEE
S ELMPOS=$P(X,SEGID,2) I 'ELMPOS!(ELMPOS'?2N) W !,"Invalid Data Element position (",ELMPOS,").",$C(7) G CEE
W " ",$P($G(ALLASAP(SEGID,+ELMPOS)),"^",2) W !
S CUSELM=X
I ELMPOS>1,'$D(ALLASAP(SEGID,ELMPOS-1)) D G CEE
. W !,"Invalid Data Element position (",ELMPOS,"). Next Data Element must be ",SEGID,$E(100+$O(ALLASAP(SEGID,99),-1)+1,2,3),".",$C(7)
;
S ELMPOS=+ELMPOS
I $D(STDASAP(SEGID,ELMPOS)) D
. ; Data Element Maximum Length
. S X=$$ASKFLD("58.400111,.04",$P($G(ALLASAP(SEGID,ELMPOS)),"^",4)) I X="^" Q
. S MAXLEN=X
. ; Data Element Requirement
. S X=$$ASKFLD("58.400111,.06",$P($G(ALLASAP(SEGID,ELMPOS)),"^",6)) I X="^" Q
. S ELMREQ=X
. ; Data Element M Expression
. S MEXPR="" F I=1:1 Q:'$D(ALLASAP(SEGID,ELMPOS,"VAL",I)) D
. . S MEXPR=MEXPR_ALLASAP(SEGID,ELMPOS,"VAL",I)
. S X=$$ASKMEXPR($P(ALLASAP(SEGID),"^",6),CUSELM,MAXLEN,MEXPR) I X="^" Q
. S MEXPR=X
. W ! S X=$$ASKFLD("Y","YES","Save Custom Data Element") I X'=1 Q
. W ?40,"Saving..."
. ; If first time the Data Element is being customized, copy; otherwise save
. I '$D(CUSASAP(SEGID,ELMPOS)) D
. . ; The Custom ASAP Segment node might not be present (1st time), therefore it must be created
. . I '$D(CUSASAP(SEGID)) D COPYSEG^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,SEGID)
. . S $P(STDASAP(SEGID,ELMPOS),"^",4)=MAXLEN
. . S $P(STDASAP(SEGID,ELMPOS),"^",6)=ELMREQ
. . S STDASAP(SEGID,ELMPOS,"VAL",1)=MEXPR
. . D COPYELM^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,CUSELM)
. E D
. . S $P(CUSASAP(SEGID,ELMPOS),"^",4)=MAXLEN
. . S $P(CUSASAP(SEGID,ELMPOS),"^",6)=ELMREQ
. . S CUSASAP(SEGID,ELMPOS,"VAL",1)=MEXPR
. . K ELMDATA M ELMDATA=CUSASAP(SEGID,ELMPOS)
. . D SAVEELM^PSOSPMU3(PSOASVER,SEGID,CUSELM,.ELMDATA)
. W "OK",$C(7)
E D
. K ELMDATA S (Y,NEWELM)=0
. I '$D(CUSASAP(SEGID,ELMPOS)) D I $D(DIRUT)!$D(DTOUT)!'Y Q
. . K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you adding '"_CUSELM_"' as a new DATA ELEMENT" W $C(7) D ^DIR
. . S NEWELM=1 W !
. ; Data Element ID and Position are non-editable fields
. S $P(ELMDATA,"^",1)=CUSELM
. S $P(ELMDATA,"^",5)=ELMPOS
. ; Data Element Name
. S X=$$ASKFLD("58.400111,.02",$P($G(CUSASAP(SEGID,ELMPOS)),"^",2)) I X="^" Q
. S $P(ELMDATA,"^",2)=X
. ; Data Element Format
. S X=$$ASKFLD("58.400111,.03",$P($G(CUSASAP(SEGID,ELMPOS)),"^",3)) I X="^" Q
. S $P(ELMDATA,"^",3)=X
. ; Data Element Maximum Length
. S X=$$ASKFLD("58.400111,.04",$P($G(CUSASAP(SEGID,ELMPOS)),"^",4)) I X="^" Q
. S $P(ELMDATA,"^",4)=X
. ; Data Element Requirement
. S X=$$ASKFLD("58.400111,.06",$P($G(CUSASAP(SEGID,ELMPOS)),"^",6)) I X="^" Q
. S $P(ELMDATA,"^",6)=X
. ; Data Element Description
. W !,"DESCRIPTION:" K ^TMP("PSOASDES",$J)
. ; Transferring Description from Local Array ALLASAP to ^TMP($J)
. F I=1:1 Q:'$D(ALLASAP(SEGID,ELMPOS,"DES",I)) D
. . S ^TMP("PSOASDES",$J,I,0)=ALLASAP(SEGID,ELMPOS,"DES",I)
. K DIC S DWPK=1,DIC="^TMP(""PSOASDES"","_$J_"," D EN^DIWE
. ; Transferring Description from ^TMP($J) to Local Array CUSASAP
. F I=1:1 Q:'$D(^TMP("PSOASDES",$J,I,0)) D
. . S ELMDATA("DES",I)=^TMP("PSOASDES",$J,I,0)
. ; Data Element M Expression
. S DONE=0,MEXPR=""
. F I=1:1 Q:'$D(ALLASAP(SEGID,ELMPOS,"VAL",I)) D
. . S MEXPR=MEXPR_ALLASAP(SEGID,ELMPOS,"VAL",I)
. S X=$$ASKMEXPR($P(ALLASAP(SEGID),"^",6),CUSELM,$P(ELMDATA,"^",4),MEXPR) I X="^" Q
. S ELMDATA("VAL",1)=X
. ; Confirm
. W ! S X=$$ASKFLD("Y","YES","Save Custom Data Element") I X'=1 Q
. W ?40,"Saving..."
. ; The Custom ASAP Segment node might not be present, therefore it must be created
. I $G(CUSASAP(SEGID))="" D COPYSEG^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,SEGID)
. D SAVEELM^PSOSPMU3(PSOASVER,SEGID,$S(NEWELM:"+1",1:CUSELM),.ELMDATA)
. W "OK",$C(7)
G CEL
;
ASKFLD(FIELD,DEFAULT,PROMPT) ; Prompt
;Input: (r) FIELD - DD Field reference (e.g., "58.40011;.02") for ^DIR call
; (o) DEFAULT - Default value
; (o) PROMPT - Alternative prompt label
;Output: User entered value or "^"
N ASKFLD,DIR,DTOUT,DIRUT,X,Y,DONE
S ASKFLD="",DIR(0)=FIELD S:$G(DEFAULT)'="" DIR("B")=DEFAULT S:$G(PROMPT)'="" DIR("A")=PROMPT
S DONE=0 F D ^DIR D I DONE Q
. I X["^",$L(X)>1 W !,"Jumping is not supported. Enter '^' to exit.",$C(7) Q
. I X="@" S ASKFLD=X,DONE=1 Q
. I (X'=""),$D(DIRUT)!$D(DTOUT) S DONE=1 Q
. S ASKFLD=Y,DONE=1
I X'="",X'="@",$D(DIRUT)!$D(DTOUT) S ASKFLD="^"
Q ASKFLD
;
ASKMEXPR(LEVEL,ELMID,MAXLEN,DEFAULT) ; Prompt for M SET Expression
;Input: (r) LEVEL - Level of the Segment where the Data Element is located
; (r) ELMID - Data Element ID ("PHA01", "DSP02", etc.)
; (r) MAXLEN - Element ID value Maximum Length
; (o) DEFAULT - Default value
;Output: M SET Expression or "^"
N ASKMEXPR,DONE,ERROR
S DONE=0,X=$G(DEFAULT)
F D I DONE Q
. S X=$G(DEFAULT) W !,"M SET EXPRESSION: "_$S(X'="":X_"// ",1:"")
. R X:DTIME S:X="" X=$G(DEFAULT) I '$T!(X="^") S ASKMEXPR="^",DONE=1 Q
. I X["?" W ! D MEXPRHLP^PSOSPML3(LEVEL,ELMID) W ! Q
. I '$$VALID^PSOSPMU3(PSOASVER,X) W !,$P($$VALID^PSOSPMU3(PSOASVER,X),"^",2),$C(7),! Q
. I '$$CHKVAR^PSOSPMU3(LEVEL,X) Q
. D CHKCODE^PSOSPMU3(LEVEL,X,.ERROR) I ERROR Q
. I $E(X,1)="""",$E(X,$L(X))="""",$E(X,2,$L(X)-1)'["""",$L(X)-2>MAXLEN D Q
. . W !,"The length cannot be longer than the maximum (",MAXLEN,").",$C(7),!
. S ASKMEXPR=X,DONE=1
Q ASKMEXPR
;
SECKEY() ; Checking the Security Key PSO SPMP ADMIN for certain actions
I '$D(^XUSEC("PSO SPMP ADMIN",DUZ)) S VALMSG="PSO SPMP ADMIN key required for this action!" W $C(7) Q 0
Q 1
;
LOCK() ; Try to LOCK the SPMP ASAP RECORD DEFINITION file (#58.4)
L +^PS(58.4):0 I '$T D Q 0
. S VALMSG="Another user is editing the ASAP Definitions" W $C(7)
Q 1
;
BACK ; Unlock ASAP Definition File Go Back to the list
L -^PS(58.4)
D INIT^PSOSPML3,HDR^PSOSPML3 I 'VALMCNT Q
EXIT ; Exit without rebuilding the list
S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSPMA3 15179 printed Oct 16, 2024@18:35:35 Page 2
PSOSPMA3 ;BIRM/MFR - ASAP Definitions Listman Actions Handler ;11/11/15
+1 ;;7.0;OUTPATIENT PHARMACY;**451,625**;DEC 1997;Build 42
+2 ;
SHOWHID ; Handles Show/Hide Details
+1 ; (PSOSHOW: 1: Show Segment Tree only; 2: Show Segments & Data Elements; 3: Show Data Element Details)
+2 SET VALMBCK="R"
+3 IF PSOASVER="1995"
Begin DoDot:1
+4 SET VALMSG="Details not available for ASAP 1995 version"
WRITE $CHAR(7)
End DoDot:1
QUIT
+5 WRITE ?52,"Please wait..."
SET PSOSHOW=(($GET(PSOSHOW)+1)#3)
+6 DO INIT^PSOSPML3
DO HDR^PSOSPML3
IF PSOSHOW=0
SET VALMBG=1
+7 QUIT
+8 ;
COPYVER ; Handles 'Copy ASAP Version' Action
+1 NEW NEWASVER,DIR,DIRUT,DTOUT,Y,X,VERS,DEFTYPE
+2 IF PSOASVER="1995"
SET VALMSG="ASAP 1995 Version cannot be copied"
WRITE $CHAR(7)
GOTO EXIT
+3 IF '$$SECKEY()
GOTO EXIT
+4 IF '$$LOCK()
GOTO EXIT
+5 DO FULL^VALM1
+6 IF PSOASVER="1995"
Begin DoDot:1
+7 SET VALMSG="ASAP 1995 Version cannot be copied"
WRITE $CHAR(7)
End DoDot:1
GOTO BACK
CV ; Loop Prompt
+1 WRITE !!," From ASAP Version: ",PSOASVER,!
+2 SET DIR(0)="58.4001,.01"
SET DIR("A")=" To ASAP Version"
DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)
GOTO BACK
+3 ;adding "B" for Zero Report
DO VERLIST^PSOSPMU0("A","B",.VERS)
+4 IF $DATA(VERS(Y_" "))
WRITE !!?3,"ASAP Version '",Y,"' already exists.",$CHAR(7)
GOTO CV
+5 SET NEWASVER=Y
+6 SET X=""
SET DEFTYPE="B"
+7 IF $GET(VERS(PSOASVER_" "))="C"
Begin DoDot:1
+8 WRITE !
SET X=$$ASKFLD("Y","YES","Copy Customizations")
IF X="^"
QUIT
+9 SET DEFTYPE=$SELECT(X=1:"B",1:"S")
End DoDot:1
IF X="^"
GOTO BACK
+10 WRITE !
SET X=$$ASKFLD("Y","NO","Confirm Copy")
IF X'=1
GOTO BACK
+11 WRITE ?40,"Copying..."
DO CLONEVER^PSOSPMU3(PSOASVER,NEWASVER,DEFTYPE)
HANG 1
WRITE "Done.",$CHAR(7)
+12 SET PSOASVER=NEWASVER
+13 GOTO BACK
+14 ;
EDTDELIM ; Handles the 'Edit Delimiters' Action
+1 NEW ELMDELIM,SEGDELIM,EOSCHR,X,DONE
+2 IF PSOASVER="1995"
SET VALMSG="Delimiters cannot be changed for ASAP 1995 Version"
WRITE $CHAR(7)
GOTO EXIT
+3 IF '$$SECKEY()
GOTO EXIT
+4 IF '$$LOCK()
GOTO EXIT
+5 DO FULL^VALM1
+6 WRITE !!,"ASAP Version ",PSOASVER," delimiters: ",!
+7 ; Both ASAP Definitions
DO LOADASAP^PSOSPMU0(PSOASVER,"B",.ALLASAP)
+8 ; Data Element Delimiter
+9 SET DONE=0
SET ELMDELIM=$PIECE($GET(ALLASAP),"^",2)
+10 FOR
SET X=$$ASKFLD("58.4001,.02",ELMDELIM)
if X="^"
QUIT
Begin DoDot:1
+11 SET ELMDELIM=$SELECT(X="@":"",1:X)
IF X="@"
WRITE ?50,"Deleted."
QUIT
+12 SET DONE=1
End DoDot:1
IF DONE
QUIT
+13 ; Segment Terminator
+14 SET DONE=0
SET SEGDELIM=$PIECE($GET(ALLASAP),"^",3)
+15 FOR
SET X=$$ASKFLD("58.4001,.03",SEGDELIM)
if X="^"
QUIT
Begin DoDot:1
+16 SET SEGDELIM=$SELECT(X="@":"",1:X)
IF X="@"
WRITE ?50,"Deleted."
QUIT
+17 SET DONE=1
End DoDot:1
IF DONE
QUIT
+18 IF X="^"
GOTO BACK
+19 ; End-Of-Segment
+20 SET DONE=0
SET EOSCHR=$PIECE($GET(ALLASAP),"^",4)
+21 FOR
SET X=$$ASKFLD("58.4001,.04",EOSCHR)
if X="^"
QUIT
Begin DoDot:1
+22 IF X'=""
IF X'="@"
IF $$UP^XLFSTR(X)'?1"$C("1.3N.(1","1.3N)1")"
Begin DoDot:2
+23 WRITE !,"Invalid format. Use $C to specify a character escape sequence.",$CHAR(7),!
End DoDot:2
QUIT
+24 SET EOSCHR=$SELECT(X="@":"",1:X)
IF X="@"
WRITE ?50,"Deleted."
QUIT
+25 SET DONE=1
End DoDot:1
IF DONE
QUIT
+26 IF X="^"
GOTO BACK
+27 ; No changes
+28 IF $PIECE($GET(ALLASAP),"^",2,4)=(ELMDELIM_"^"_SEGDELIM_"^"_EOSCHR)
GOTO BACK
+29 ;
+30 WRITE !
SET X=$$ASKFLD("Y","YES","Save Changes")
IF X'=1
GOTO BACK
+31 WRITE ?40,"Saving..."
+32 SET $PIECE(ALLASAP,"^",2,4)=ELMDELIM_"^"_SEGDELIM_"^"_EOSCHR
+33 DO SAVEVER^PSOSPMU3(PSOASVER,ALLASAP)
+34 HANG 1
WRITE "OK",$CHAR(7)
+35 GOTO BACK
+36 ;
CUSSEG ; Handles the 'Customize Segment' Action
+1 NEW CUSSEG,DIR,DIRUT,DTOUT,X,Y,STDASAP,CUSASAP,ALLASAP,NEWSEG,DONE,QUIT,SEG,OK,SEGREQ,SEGPOS,PARSEG
+2 NEW HLPTXT,CUSSEGS,CNT,LITERAL
+3 IF PSOASVER="1995"
SET VALMSG="ASAP 1995 Version cannot be customized"
WRITE $CHAR(7)
GOTO EXIT
+4 IF '$$SECKEY()
GOTO EXIT
+5 IF '$$LOCK()
GOTO EXIT
+6 DO FULL^VALM1
+7 ;
CSL ; Loop Re-Prompt
+1 ; Standard ASAP Definition
DO LOADASAP^PSOSPMU0(PSOASVER,"S",.STDASAP)
+2 ; Custom ASAP Definition
DO LOADASAP^PSOSPMU0(PSOASVER,"C",.CUSASAP)
+3 ; Both ASAP Definitions
DO LOADASAP^PSOSPMU0(PSOASVER,"B",.ALLASAP)
+4 ;
CSE ; Error Re-Prompt
+1 KILL DIR
SET HLPTXT="Enter the ASAP Segment ID that you want to customize (e.g.,'AIR')."
+2 IF $GET(STDASAP)'=""
Begin DoDot:1
+3 SET SEG="999"
FOR
SET SEG=$ORDER(CUSASAP(SEG))
if SEG=""
QUIT
Begin DoDot:2
+4 IF $$CUSSEG^PSOSPMU3(PSOASVER,SEG)
SET CUSSEGS(SEG)=$PIECE(CUSASAP(SEG),"^",2)
End DoDot:2
End DoDot:1
+5 IF '$DATA(CUSSEGS)
Begin DoDot:1
+6 SET DIR("?")=HLPTXT
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET DIR("?",1)=HLPTXT
SET (DIR("?"),DIR("?",2))=" "
+9 SET SEG=""
SET CNT=3
FOR
SET SEG=$ORDER(CUSSEGS(SEG))
if SEG=""
QUIT
Begin DoDot:2
+10 IF $ORDER(CUSSEGS(SEG))=""
SET DIR("?")=SEG_" "_$PIECE(CUSSEGS(SEG),"^")
QUIT
+11 SET DIR("?",CNT)=SEG_" "_$PIECE(CUSSEGS(SEG),"^")
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+12 SET DIR(0)="FO^1:5"
SET DIR("A")="SEGMENT ID"
+13 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!(X="")
GOTO BACK
+14 SET LITERAL=0
IF $EXTRACT(X)=""""
IF $EXTRACT(X,$LENGTH(X))=""""
SET X=$EXTRACT(X,2,$LENGTH(X)-1)
SET LITERAL=1
+15 IF (X'?.AN)!($EXTRACT(X,$LENGTH(X))?1N)!(X[" ")
WRITE !,"Invalid Segment ID.",$CHAR(7)
GOTO CSE
+16 IF 'LITERAL
IF '$DATA(ALLASAP(X))
IF $DATA(ALLASAP($$UP^XLFSTR(X)))
SET X=$$UP^XLFSTR(X)
+17 SET CUSSEG=X
WRITE " ",$PIECE($GET(ALLASAP(CUSSEG)),"^",2)
WRITE !
+18 IF $DATA(STDASAP(CUSSEG))
Begin DoDot:1
+19 ; Segment Requirement
+20 SET X=$$ASKFLD("58.40011,.04",$PIECE($GET(ALLASAP(CUSSEG)),"^",4))
IF X="^"
QUIT
+21 SET SEGREQ=X
+22 WRITE !
SET X=$$ASKFLD("Y","YES","Save Custom Segment")
IF X'=1
QUIT
+23 WRITE ?40,"Saving..."
+24 ; If first time the Segment is being customized, copy; otherwise save
+25 IF '$DATA(CUSASAP(CUSSEG))
Begin DoDot:2
+26 SET $PIECE(STDASAP(CUSSEG),"^",4)=SEGREQ
+27 DO COPYSEG^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,CUSSEG)
End DoDot:2
+28 IF '$TEST
Begin DoDot:2
+29 SET $PIECE(CUSASAP(CUSSEG),"^",4)=SEGREQ
+30 DO SAVESEG^PSOSPMU3(PSOASVER,CUSSEG,CUSASAP(CUSSEG),ALLASAP)
End DoDot:2
+31 WRITE "OK",$CHAR(7)
End DoDot:1
+32 IF '$TEST
Begin DoDot:1
+33 SET (Y,NEWSEG)=0
+34 IF '$DATA(CUSASAP(CUSSEG))
Begin DoDot:2
+35 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Are you adding '"_CUSSEG_"' as a new SEGMENT ID"
WRITE $CHAR(7)
DO ^DIR
+36 SET NEWSEG=1
WRITE !
End DoDot:2
IF $DATA(DIRUT)!$DATA(DTOUT)!'Y
QUIT
+37 SET $PIECE(CUSASAP(CUSSEG),"^",1)=CUSSEG
+38 ; Segment Name
+39 SET X=$$ASKFLD("58.40011,.02",$PIECE(CUSASAP(CUSSEG),"^",2))
IF X="^"
QUIT
+40 SET $PIECE(CUSASAP(CUSSEG),"^",2)=X
+41 ; Parent Segment
+42 SET DONE=0
+43 FOR
SET X=$$ASKFLD("58.40011,.03",$PIECE(CUSASAP(CUSSEG),"^",3))
if X="^"!(X="")
QUIT
Begin DoDot:2
+44 IF X="@"
SET $PIECE(CUSASAP(CUSSEG),"^",3)=""
QUIT
+45 IF '$DATA(ALLASAP(X))
IF $DATA(ALLASAP($$UP^XLFSTR(X)))
SET X=$$UP^XLFSTR(X)
+46 IF '$DATA(ALLASAP(X))
WRITE !,"Parent Segment ID not found.",$CHAR(7)
QUIT
+47 IF X=CUSSEG
WRITE !,"Parent Segment ID cannot be its own parent.",$CHAR(7)
QUIT
+48 WRITE " ",$PIECE(ALLASAP(X),"^",2)
+49 SET $PIECE(CUSASAP(CUSSEG),"^",3)=X
SET DONE=1
End DoDot:2
IF DONE
QUIT
+50 IF X="^"
QUIT
+51 ; Segment Requirement
+52 SET X=$$ASKFLD("58.40011,.04",$PIECE(CUSASAP(CUSSEG),"^",4))
IF X="^"
QUIT
+53 SET $PIECE(CUSASAP(CUSSEG),"^",4)=X
+54 SET DONE=0
+55 FOR
SET X=$$ASKFLD("58.40011,.05",$PIECE(CUSASAP(CUSSEG),"^",5))
if X="^"
QUIT
Begin DoDot:2
+56 SET SEG="999"
SET OK=1
FOR
SET SEG=$ORDER(ALLASAP(SEG))
if SEG=""
QUIT
Begin DoDot:3
+57 IF SEG'=CUSSEG
IF $PIECE(ALLASAP(SEG),"^",3)=$PIECE(CUSASAP(CUSSEG),"^",3)
IF $PIECE(ALLASAP(SEG),"^",5)=X
Begin DoDot:4
+58 SET OK=0
WRITE !,"The Segment '",SEG,"' (",$PIECE(ALLASAP(SEG),"^",2),") already occupies this position.",$CHAR(7)
QUIT
End DoDot:4
End DoDot:3
IF 'OK
QUIT
+59 IF OK
SET $PIECE(CUSASAP(CUSSEG),"^",5)=X
SET DONE=1
End DoDot:2
IF DONE
QUIT
+60 IF X="^"
QUIT
+61 ; Segment Level
+62 SET DONE=0
SET PARSEG=$PIECE(CUSASAP(CUSSEG),"^",3)
+63 IF PARSEG'=""
IF $PIECE(CUSASAP(CUSSEG),"^",6)=""
IF $PIECE($GET(ALLASAP(PARSEG)),"^",6)>3
Begin DoDot:2
+64 SET $PIECE(CUSASAP(CUSSEG),"^",6)=$PIECE($GET(ALLASAP(PARSEG)),"^",6)
End DoDot:2
+65 FOR
SET X=$$ASKFLD("58.40011,.06",$PIECE(CUSASAP(CUSSEG),"^",6))
if X="^"
QUIT
Begin DoDot:2
+66 IF $PIECE(CUSASAP(CUSSEG),"^",3)=""
IF X'=1
IF X'=6
Begin DoDot:3
+67 WRITE !,"Orphan segments can only be located at the MAIN HEADER or MAIN TRAILER levels.",$CHAR(7)
End DoDot:3
QUIT
+68 SET QUIT=0
+69 IF PARSEG'=""
Begin DoDot:3
+70 IF $PIECE($GET(ALLASAP(PARSEG)),"^",6)>3
IF X'=$PIECE($GET(ALLASAP(PARSEG)),"^",6)
Begin DoDot:4
+71 WRITE !,"Segment level must be the same as the parent's level (",$PIECE($GET(ALLASAP(PARSEG)),"^",6),").",$CHAR(7)
End DoDot:4
SET QUIT=1
QUIT
+72 IF X<$PIECE($GET(ALLASAP(PARSEG)),"^",6)
Begin DoDot:4
+73 WRITE !,"Segment level cannot be lower than parent's level (",$PIECE($GET(ALLASAP(PARSEG)),"^",6),").",$CHAR(7)
End DoDot:4
SET QUIT=1
QUIT
+74 IF X>($PIECE($GET(ALLASAP(PARSEG)),"^",6)+1)
Begin DoDot:4
+75 WRITE !,"Segment level cannot be more than 1 level above parent's level (",$PIECE($GET(ALLASAP(PARSEG)),"^",6),").",$CHAR(7)
End DoDot:4
SET QUIT=1
QUIT
End DoDot:3
IF QUIT
QUIT
+76 SET $PIECE(CUSASAP(CUSSEG),"^",6)=X
SET DONE=1
End DoDot:2
IF DONE
QUIT
+77 IF X="^"
QUIT
+78 ; Confirm
+79 WRITE !
SET X=$$ASKFLD("Y","YES","Save Custom Segment")
IF X'=1
QUIT
+80 WRITE ?40,"Saving..."
+81 DO SAVESEG^PSOSPMU3(PSOASVER,$SELECT(NEWSEG:"+1",1:CUSSEG),CUSASAP(CUSSEG),ALLASAP)
+82 HANG 1
WRITE "OK",$CHAR(7)
End DoDot:1
+83 GOTO CSL
+84 ;
CUSELM ; Handles the 'Customize Element' Action
+1 NEW CUSELM,DIR,DIRUT,DTOUT,X,Y,STDASAP,CUSASAP,SEGID,ELMPOS,MAXLEN,ELMREQ,NEWELM,ELMDATA
+2 NEW DIC,DWPK,I,MEXPR,LINE,HLPTXT,CUSELMS,CNT,ELM
+3 IF PSOASVER="1995"
SET VALMSG="ASAP 1995 Version cannot be customized"
WRITE $CHAR(7)
GOTO EXIT
+4 IF '$$SECKEY()
GOTO EXIT
+5 IF '$$LOCK()
GOTO EXIT
+6 DO FULL^VALM1
+7 ;
CEL ; Loop Re-Prompt
+1 ; Standard ASAP Definition
DO LOADASAP^PSOSPMU0(PSOASVER,"S",.STDASAP)
+2 ; Custom ASAP Definition
DO LOADASAP^PSOSPMU0(PSOASVER,"C",.CUSASAP)
+3 ; Both ASAP Definitions
DO LOADASAP^PSOSPMU0(PSOASVER,"B",.ALLASAP)
+4 ;
CEE ; Error Re-Prompt
+1 KILL DIR
SET HLPTXT="Enter the ASAP Data Element ID that you want to customize (e.g.,'PAT03')"
+2 IF $GET(STDASAP)'=""
Begin DoDot:1
+3 SET SEG="999"
FOR
SET SEG=$ORDER(CUSASAP(SEG))
if SEG=""
QUIT
Begin DoDot:2
+4 SET ELM=0
FOR
SET ELM=$ORDER(CUSASAP(SEG,ELM))
if 'ELM
QUIT
Begin DoDot:3
+5 SET CUSELMS($PIECE(CUSASAP(SEG,ELM),"^"))=$PIECE(CUSASAP(SEG,ELM),"^",2)
End DoDot:3
End DoDot:2
End DoDot:1
+6 IF '$DATA(CUSELMS)
Begin DoDot:1
+7 SET DIR("?")=HLPTXT
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET DIR("?",1)=HLPTXT
SET (DIR("?"),DIR("?",2))=" "
+10 SET CNT=2
SET ELM=""
FOR
SET ELM=$ORDER(CUSELMS(ELM))
if ELM=""
QUIT
Begin DoDot:2
+11 IF $ORDER(CUSELMS(ELM))=""
SET DIR("?")=ELM_" "_$PIECE(CUSELMS(ELM),"^")
QUIT
+12 SET DIR("?",CNT)=ELM_" "_$PIECE(CUSELMS(ELM),"^")
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+13 SET DIR(0)="FO^1:10"
SET DIR("A")="DATA ELEMENT ID"
+14 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!(X="")
GOTO BACK
+15 SET SEGID=$$GETSEGID^PSOSPMU3(X)
IF SEGID=""!(X[" ")
WRITE !,"Invalid Segment.",$CHAR(7)
GOTO CEE
+16 IF '$DATA(ALLASAP(SEGID))
IF $DATA(ALLASAP($$UP^XLFSTR(SEGID)))
Begin DoDot:1
+17 SET X=$$UP^XLFSTR(X)
SET SEGID=$$UP^XLFSTR(SEGID)
End DoDot:1
+18 IF '$DATA(ALLASAP(SEGID))
WRITE !!,"Segment ID '",SEGID,"' not found.",$CHAR(7)
GOTO CEE
+19 SET ELMPOS=$PIECE(X,SEGID,2)
IF 'ELMPOS!(ELMPOS'?2N)
WRITE !,"Invalid Data Element position (",ELMPOS,").",$CHAR(7)
GOTO CEE
+20 WRITE " ",$PIECE($GET(ALLASAP(SEGID,+ELMPOS)),"^",2)
WRITE !
+21 SET CUSELM=X
+22 IF ELMPOS>1
IF '$DATA(ALLASAP(SEGID,ELMPOS-1))
Begin DoDot:1
+23 WRITE !,"Invalid Data Element position (",ELMPOS,"). Next Data Element must be ",SEGID,$EXTRACT(100+$ORDER(ALLASAP(SEGID,99),-1)+1,2,3),".",$CHAR(7)
End DoDot:1
GOTO CEE
+24 ;
+25 SET ELMPOS=+ELMPOS
+26 IF $DATA(STDASAP(SEGID,ELMPOS))
Begin DoDot:1
+27 ; Data Element Maximum Length
+28 SET X=$$ASKFLD("58.400111,.04",$PIECE($GET(ALLASAP(SEGID,ELMPOS)),"^",4))
IF X="^"
QUIT
+29 SET MAXLEN=X
+30 ; Data Element Requirement
+31 SET X=$$ASKFLD("58.400111,.06",$PIECE($GET(ALLASAP(SEGID,ELMPOS)),"^",6))
IF X="^"
QUIT
+32 SET ELMREQ=X
+33 ; Data Element M Expression
+34 SET MEXPR=""
FOR I=1:1
if '$DATA(ALLASAP(SEGID,ELMPOS,"VAL",I))
QUIT
Begin DoDot:2
+35 SET MEXPR=MEXPR_ALLASAP(SEGID,ELMPOS,"VAL",I)
End DoDot:2
+36 SET X=$$ASKMEXPR($PIECE(ALLASAP(SEGID),"^",6),CUSELM,MAXLEN,MEXPR)
IF X="^"
QUIT
+37 SET MEXPR=X
+38 WRITE !
SET X=$$ASKFLD("Y","YES","Save Custom Data Element")
IF X'=1
QUIT
+39 WRITE ?40,"Saving..."
+40 ; If first time the Data Element is being customized, copy; otherwise save
+41 IF '$DATA(CUSASAP(SEGID,ELMPOS))
Begin DoDot:2
+42 ; The Custom ASAP Segment node might not be present (1st time), therefore it must be created
+43 IF '$DATA(CUSASAP(SEGID))
DO COPYSEG^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,SEGID)
+44 SET $PIECE(STDASAP(SEGID,ELMPOS),"^",4)=MAXLEN
+45 SET $PIECE(STDASAP(SEGID,ELMPOS),"^",6)=ELMREQ
+46 SET STDASAP(SEGID,ELMPOS,"VAL",1)=MEXPR
+47 DO COPYELM^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,CUSELM)
End DoDot:2
+48 IF '$TEST
Begin DoDot:2
+49 SET $PIECE(CUSASAP(SEGID,ELMPOS),"^",4)=MAXLEN
+50 SET $PIECE(CUSASAP(SEGID,ELMPOS),"^",6)=ELMREQ
+51 SET CUSASAP(SEGID,ELMPOS,"VAL",1)=MEXPR
+52 KILL ELMDATA
MERGE ELMDATA=CUSASAP(SEGID,ELMPOS)
+53 DO SAVEELM^PSOSPMU3(PSOASVER,SEGID,CUSELM,.ELMDATA)
End DoDot:2
+54 WRITE "OK",$CHAR(7)
End DoDot:1
+55 IF '$TEST
Begin DoDot:1
+56 KILL ELMDATA
SET (Y,NEWELM)=0
+57 IF '$DATA(CUSASAP(SEGID,ELMPOS))
Begin DoDot:2
+58 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Are you adding '"_CUSELM_"' as a new DATA ELEMENT"
WRITE $CHAR(7)
DO ^DIR
+59 SET NEWELM=1
WRITE !
End DoDot:2
IF $DATA(DIRUT)!$DATA(DTOUT)!'Y
QUIT
+60 ; Data Element ID and Position are non-editable fields
+61 SET $PIECE(ELMDATA,"^",1)=CUSELM
+62 SET $PIECE(ELMDATA,"^",5)=ELMPOS
+63 ; Data Element Name
+64 SET X=$$ASKFLD("58.400111,.02",$PIECE($GET(CUSASAP(SEGID,ELMPOS)),"^",2))
IF X="^"
QUIT
+65 SET $PIECE(ELMDATA,"^",2)=X
+66 ; Data Element Format
+67 SET X=$$ASKFLD("58.400111,.03",$PIECE($GET(CUSASAP(SEGID,ELMPOS)),"^",3))
IF X="^"
QUIT
+68 SET $PIECE(ELMDATA,"^",3)=X
+69 ; Data Element Maximum Length
+70 SET X=$$ASKFLD("58.400111,.04",$PIECE($GET(CUSASAP(SEGID,ELMPOS)),"^",4))
IF X="^"
QUIT
+71 SET $PIECE(ELMDATA,"^",4)=X
+72 ; Data Element Requirement
+73 SET X=$$ASKFLD("58.400111,.06",$PIECE($GET(CUSASAP(SEGID,ELMPOS)),"^",6))
IF X="^"
QUIT
+74 SET $PIECE(ELMDATA,"^",6)=X
+75 ; Data Element Description
+76 WRITE !,"DESCRIPTION:"
KILL ^TMP("PSOASDES",$JOB)
+77 ; Transferring Description from Local Array ALLASAP to ^TMP($J)
+78 FOR I=1:1
if '$DATA(ALLASAP(SEGID,ELMPOS,"DES",I))
QUIT
Begin DoDot:2
+79 SET ^TMP("PSOASDES",$JOB,I,0)=ALLASAP(SEGID,ELMPOS,"DES",I)
End DoDot:2
+80 KILL DIC
SET DWPK=1
SET DIC="^TMP(""PSOASDES"","_$JOB_","
DO EN^DIWE
+81 ; Transferring Description from ^TMP($J) to Local Array CUSASAP
+82 FOR I=1:1
if '$DATA(^TMP("PSOASDES",$JOB,I,0))
QUIT
Begin DoDot:2
+83 SET ELMDATA("DES",I)=^TMP("PSOASDES",$JOB,I,0)
End DoDot:2
+84 ; Data Element M Expression
+85 SET DONE=0
SET MEXPR=""
+86 FOR I=1:1
if '$DATA(ALLASAP(SEGID,ELMPOS,"VAL",I))
QUIT
Begin DoDot:2
+87 SET MEXPR=MEXPR_ALLASAP(SEGID,ELMPOS,"VAL",I)
End DoDot:2
+88 SET X=$$ASKMEXPR($PIECE(ALLASAP(SEGID),"^",6),CUSELM,$PIECE(ELMDATA,"^",4),MEXPR)
IF X="^"
QUIT
+89 SET ELMDATA("VAL",1)=X
+90 ; Confirm
+91 WRITE !
SET X=$$ASKFLD("Y","YES","Save Custom Data Element")
IF X'=1
QUIT
+92 WRITE ?40,"Saving..."
+93 ; The Custom ASAP Segment node might not be present, therefore it must be created
+94 IF $GET(CUSASAP(SEGID))=""
DO COPYSEG^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,SEGID)
+95 DO SAVEELM^PSOSPMU3(PSOASVER,SEGID,$SELECT(NEWELM:"+1",1:CUSELM),.ELMDATA)
+96 WRITE "OK",$CHAR(7)
End DoDot:1
+97 GOTO CEL
+98 ;
ASKFLD(FIELD,DEFAULT,PROMPT) ; Prompt
+1 ;Input: (r) FIELD - DD Field reference (e.g., "58.40011;.02") for ^DIR call
+2 ; (o) DEFAULT - Default value
+3 ; (o) PROMPT - Alternative prompt label
+4 ;Output: User entered value or "^"
+5 NEW ASKFLD,DIR,DTOUT,DIRUT,X,Y,DONE
+6 SET ASKFLD=""
SET DIR(0)=FIELD
if $GET(DEFAULT)'=""
SET DIR("B")=DEFAULT
if $GET(PROMPT)'=""
SET DIR("A")=PROMPT
+7 SET DONE=0
FOR
DO ^DIR
Begin DoDot:1
+8 IF X["^"
IF $LENGTH(X)>1
WRITE !,"Jumping is not supported. Enter '^' to exit.",$CHAR(7)
QUIT
+9 IF X="@"
SET ASKFLD=X
SET DONE=1
QUIT
+10 IF (X'="")
IF $DATA(DIRUT)!$DATA(DTOUT)
SET DONE=1
QUIT
+11 SET ASKFLD=Y
SET DONE=1
End DoDot:1
IF DONE
QUIT
+12 IF X'=""
IF X'="@"
IF $DATA(DIRUT)!$DATA(DTOUT)
SET ASKFLD="^"
+13 QUIT ASKFLD
+14 ;
ASKMEXPR(LEVEL,ELMID,MAXLEN,DEFAULT) ; Prompt for M SET Expression
+1 ;Input: (r) LEVEL - Level of the Segment where the Data Element is located
+2 ; (r) ELMID - Data Element ID ("PHA01", "DSP02", etc.)
+3 ; (r) MAXLEN - Element ID value Maximum Length
+4 ; (o) DEFAULT - Default value
+5 ;Output: M SET Expression or "^"
+6 NEW ASKMEXPR,DONE,ERROR
+7 SET DONE=0
SET X=$GET(DEFAULT)
+8 FOR
Begin DoDot:1
+9 SET X=$GET(DEFAULT)
WRITE !,"M SET EXPRESSION: "_$SELECT(X'="":X_"// ",1:"")
+10 READ X:DTIME
if X=""
SET X=$GET(DEFAULT)
IF '$TEST!(X="^")
SET ASKMEXPR="^"
SET DONE=1
QUIT
+11 IF X["?"
WRITE !
DO MEXPRHLP^PSOSPML3(LEVEL,ELMID)
WRITE !
QUIT
+12 IF '$$VALID^PSOSPMU3(PSOASVER,X)
WRITE !,$PIECE($$VALID^PSOSPMU3(PSOASVER,X),"^",2),$CHAR(7),!
QUIT
+13 IF '$$CHKVAR^PSOSPMU3(LEVEL,X)
QUIT
+14 DO CHKCODE^PSOSPMU3(LEVEL,X,.ERROR)
IF ERROR
QUIT
+15 IF $EXTRACT(X,1)=""""
IF $EXTRACT(X,$LENGTH(X))=""""
IF $EXTRACT(X,2,$LENGTH(X)-1)'[""""
IF $LENGTH(X)-2>MAXLEN
Begin DoDot:2
+16 WRITE !,"The length cannot be longer than the maximum (",MAXLEN,").",$CHAR(7),!
End DoDot:2
QUIT
+17 SET ASKMEXPR=X
SET DONE=1
End DoDot:1
IF DONE
QUIT
+18 QUIT ASKMEXPR
+19 ;
SECKEY() ; Checking the Security Key PSO SPMP ADMIN for certain actions
+1 IF '$DATA(^XUSEC("PSO SPMP ADMIN",DUZ))
SET VALMSG="PSO SPMP ADMIN key required for this action!"
WRITE $CHAR(7)
QUIT 0
+2 QUIT 1
+3 ;
LOCK() ; Try to LOCK the SPMP ASAP RECORD DEFINITION file (#58.4)
+1 LOCK +^PS(58.4):0
IF '$TEST
Begin DoDot:1
+2 SET VALMSG="Another user is editing the ASAP Definitions"
WRITE $CHAR(7)
End DoDot:1
QUIT 0
+3 QUIT 1
+4 ;
BACK ; Unlock ASAP Definition File Go Back to the list
+1 LOCK -^PS(58.4)
+2 DO INIT^PSOSPML3
DO HDR^PSOSPML3
IF 'VALMCNT
QUIT
EXIT ; Exit without rebuilding the list
+1 SET VALMBCK="R"
+2 QUIT
