PSOSPMA3 ;BIRM/MFR - ASAP Definitions Listman Actions Handler ;11/11/15
;;7.0;OUTPATIENT PHARMACY;**451,625,772**;DEC 1997;Build 105
;
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"!$$CLONE^PSOSPML3(PSOASVER) D I X="^" G BACK ; 772 "standard clone" ASAP version
. 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) ; PSO*7*772
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 STDSEGCU^PSOSPMU2(PSOASVER,.STDASAP,.CUSASAP,.ALLASAP,CUSSEG)
I '$D(STDASAP(CUSSEG)) 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))!$G(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,CLONE,SEGID,ELMPOS
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
. K ELMDATA
. N POPOUT S POPOUT=0
. ; 772 Begin
. I $L($P($G(STDASAP),"^",6)) D Q:POPOUT ; This is a cloned ASAP version, allow edit of name and format
. . ; Data Element Name
. . S X=$$ASKFLD("58.400111,.02",$P($G(ALLASAP(SEGID,ELMPOS)),"^",2)) I X="^" S POPOUT=1 Q
. . S $P(ELMDATA,"^",2)=X
. . ; Data Element Format
. . S X=$$ASKFLD("58.400111,.03",$P($G(ALLASAP(SEGID,ELMPOS)),"^",3)) I X="^" S POPOUT=1 Q
. . S $P(ELMDATA,"^",3)=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)
. . S $P(ELMDATA,"^",1)=CUSELM
. . S $P(ELMDATA,"^",5)=ELMPOS
. . ; 772 End
. ; 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)
. . I $$CLONE^PSOSPML3(PSOASVER) D CUSTDEL^PSOSPMU2(PSOASVER,SEGID,ELMPOS,ELMDATA,.STDASAP) ; PSO*7*772
. . S $P(STDASAP(SEGID,ELMPOS),"^",4)=MAXLEN
. . S $P(STDASAP(SEGID,ELMPOS),"^",6)=ELMREQ
. . S STDASAP(SEGID,ELMPOS,"VAL",1)=MEXPR
. . K STDASAP(SEGID,ELMPOS,"DES") M STDASAP(SEGID,ELMPOS,"DES")=ELMDATA("DES")
. . D COPYELM^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,CUSELM)
. I $D(CUSASAP(SEGID,ELMPOS)) D
. . I $$CLONE^PSOSPML3(PSOASVER) D CUSTDEL^PSOSPMU2(PSOASVER,SEGID,ELMPOS,ELMDATA,.CUSASAP) ; PSO*7*772
. . S $P(CUSASAP(SEGID,ELMPOS),"^",4)=MAXLEN
. . S $P(CUSASAP(SEGID,ELMPOS),"^",6)=ELMREQ
. . S CUSASAP(SEGID,ELMPOS,"VAL",1)=MEXPR
. . K CUSASAP(SEGID,ELMPOS,"DES") M CUSASAP(SEGID,ELMPOS,"DES")=ELMDATA("DES")
. . K ELMDATA M ELMDATA=CUSASAP(SEGID,ELMPOS) ; If legacy standard (not standard copy), reset element values
. . D SAVEELM^PSOSPMU3(PSOASVER,SEGID,CUSELM,.ELMDATA,$G(CLONE))
. W "OK",$C(7)
I '$D(STDASAP(SEGID,ELMPOS)) 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 16377 printed Sep 23, 2025@20:11:24 Page 2
PSOSPMA3 ;BIRM/MFR - ASAP Definitions Listman Actions Handler ;11/11/15
+1 ;;7.0;OUTPATIENT PHARMACY;**451,625,772**;DEC 1997;Build 105
+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 ; 772 "standard clone" ASAP version
IF $GET(VERS(PSOASVER_" "))="C"!$$CLONE^PSOSPML3(PSOASVER)
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 ; PSO*7*772
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))
DO STDSEGCU^PSOSPMU2(PSOASVER,.STDASAP,.CUSASAP,.ALLASAP,CUSSEG)
+19 IF '$DATA(STDASAP(CUSSEG))
Begin DoDot:1
+20 SET (Y,NEWSEG)=0
+21 IF '$DATA(CUSASAP(CUSSEG))
Begin DoDot:2
+22 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
+23 SET NEWSEG=1
WRITE !
End DoDot:2
IF $DATA(DIRUT)!$DATA(DTOUT)!'Y
QUIT
+24 SET $PIECE(CUSASAP(CUSSEG),"^",1)=CUSSEG
+25 ; Segment Name
+26 SET X=$$ASKFLD("58.40011,.02",$PIECE(CUSASAP(CUSSEG),"^",2))
IF X="^"
QUIT
+27 SET $PIECE(CUSASAP(CUSSEG),"^",2)=X
+28 ; Parent Segment
+29 SET DONE=0
+30 FOR
SET X=$$ASKFLD("58.40011,.03",$PIECE(CUSASAP(CUSSEG),"^",3))
if X="^"!(X="")
QUIT
Begin DoDot:2
+31 IF X="@"
SET $PIECE(CUSASAP(CUSSEG),"^",3)=""
QUIT
+32 IF '$DATA(ALLASAP(X))
IF $DATA(ALLASAP($$UP^XLFSTR(X)))
SET X=$$UP^XLFSTR(X)
+33 IF '$DATA(ALLASAP(X))!$GET(X)
WRITE !,"Parent Segment ID not found.",$CHAR(7)
QUIT
+34 IF X=CUSSEG
WRITE !,"Parent Segment ID cannot be its own parent.",$CHAR(7)
QUIT
+35 WRITE " ",$PIECE(ALLASAP(X),"^",2)
+36 SET $PIECE(CUSASAP(CUSSEG),"^",3)=X
SET DONE=1
End DoDot:2
IF DONE
QUIT
+37 IF X="^"
QUIT
+38 ; Segment Requirement
+39 SET X=$$ASKFLD("58.40011,.04",$PIECE(CUSASAP(CUSSEG),"^",4))
IF X="^"
QUIT
+40 SET $PIECE(CUSASAP(CUSSEG),"^",4)=X
+41 SET DONE=0
+42 FOR
SET X=$$ASKFLD("58.40011,.05",$PIECE(CUSASAP(CUSSEG),"^",5))
if X="^"
QUIT
Begin DoDot:2
+43 SET SEG="999"
SET OK=1
FOR
SET SEG=$ORDER(ALLASAP(SEG))
if SEG=""
QUIT
Begin DoDot:3
+44 IF SEG'=CUSSEG
IF $PIECE(ALLASAP(SEG),"^",3)=$PIECE(CUSASAP(CUSSEG),"^",3)
IF $PIECE(ALLASAP(SEG),"^",5)=X
Begin DoDot:4
+45 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
+46 IF OK
SET $PIECE(CUSASAP(CUSSEG),"^",5)=X
SET DONE=1
End DoDot:2
IF DONE
QUIT
+47 IF X="^"
QUIT
+48 ; Segment Level
+49 SET DONE=0
SET PARSEG=$PIECE(CUSASAP(CUSSEG),"^",3)
+50 IF PARSEG'=""
IF $PIECE(CUSASAP(CUSSEG),"^",6)=""
IF $PIECE($GET(ALLASAP(PARSEG)),"^",6)>3
Begin DoDot:2
+51 SET $PIECE(CUSASAP(CUSSEG),"^",6)=$PIECE($GET(ALLASAP(PARSEG)),"^",6)
End DoDot:2
+52 FOR
SET X=$$ASKFLD("58.40011,.06",$PIECE(CUSASAP(CUSSEG),"^",6))
if X="^"
QUIT
Begin DoDot:2
+53 IF $PIECE(CUSASAP(CUSSEG),"^",3)=""
IF X'=1
IF X'=6
Begin DoDot:3
+54 WRITE !,"Orphan segments can only be located at the MAIN HEADER or MAIN TRAILER levels.",$CHAR(7)
End DoDot:3
QUIT
+55 SET QUIT=0
+56 IF PARSEG'=""
Begin DoDot:3
+57 IF $PIECE($GET(ALLASAP(PARSEG)),"^",6)>3
IF X'=$PIECE($GET(ALLASAP(PARSEG)),"^",6)
Begin DoDot:4
+58 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
+59 IF X<$PIECE($GET(ALLASAP(PARSEG)),"^",6)
Begin DoDot:4
+60 WRITE !,"Segment level cannot be lower than parent's level (",$PIECE($GET(ALLASAP(PARSEG)),"^",6),").",$CHAR(7)
End DoDot:4
SET QUIT=1
QUIT
+61 IF X>($PIECE($GET(ALLASAP(PARSEG)),"^",6)+1)
Begin DoDot:4
+62 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
+63 SET $PIECE(CUSASAP(CUSSEG),"^",6)=X
SET DONE=1
End DoDot:2
IF DONE
QUIT
+64 IF X="^"
QUIT
+65 ; Confirm
+66 WRITE !
SET X=$$ASKFLD("Y","YES","Save Custom Segment")
IF X'=1
QUIT
+67 WRITE ?40,"Saving..."
+68 DO SAVESEG^PSOSPMU3(PSOASVER,$SELECT(NEWSEG:"+1",1:CUSSEG),CUSASAP(CUSSEG),ALLASAP)
+69 HANG 1
WRITE "OK",$CHAR(7)
End DoDot:1
+70 GOTO CSL
+71 ;
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,CLONE,SEGID,ELMPOS
+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 KILL ELMDATA
+28 NEW POPOUT
SET POPOUT=0
+29 ; 772 Begin
+30 ; This is a cloned ASAP version, allow edit of name and format
IF $LENGTH($PIECE($GET(STDASAP),"^",6))
Begin DoDot:2
+31 ; Data Element Name
+32 SET X=$$ASKFLD("58.400111,.02",$PIECE($GET(ALLASAP(SEGID,ELMPOS)),"^",2))
IF X="^"
SET POPOUT=1
QUIT
+33 SET $PIECE(ELMDATA,"^",2)=X
+34 ; Data Element Format
+35 SET X=$$ASKFLD("58.400111,.03",$PIECE($GET(ALLASAP(SEGID,ELMPOS)),"^",3))
IF X="^"
SET POPOUT=1
QUIT
+36 SET $PIECE(ELMDATA,"^",3)=X
+37 ; Data Element Description
+38 WRITE !,"DESCRIPTION:"
KILL ^TMP("PSOASDES",$JOB)
+39 ; Transferring Description from Local Array ALLASAP to ^TMP($J)
+40 FOR I=1:1
if '$DATA(ALLASAP(SEGID,ELMPOS,"DES",I))
QUIT
Begin DoDot:3
+41 SET ^TMP("PSOASDES",$JOB,I,0)=ALLASAP(SEGID,ELMPOS,"DES",I)
End DoDot:3
+42 KILL DIC
SET DWPK=1
SET DIC="^TMP(""PSOASDES"","_$JOB_","
DO EN^DIWE
+43 ; Transferring Description from ^TMP($J) to Local Array CUSASAP
+44 FOR I=1:1
if '$DATA(^TMP("PSOASDES",$JOB,I,0))
QUIT
Begin DoDot:3
+45 SET ELMDATA("DES",I)=^TMP("PSOASDES",$JOB,I,0)
End DoDot:3
+46 SET $PIECE(ELMDATA,"^",1)=CUSELM
+47 SET $PIECE(ELMDATA,"^",5)=ELMPOS
+48 ; 772 End
End DoDot:2
if POPOUT
QUIT
+49 ; Data Element Maximum Length
+50 SET X=$$ASKFLD("58.400111,.04",$PIECE($GET(ALLASAP(SEGID,ELMPOS)),"^",4))
IF X="^"
QUIT
+51 SET MAXLEN=X
+52 ; Data Element Requirement
+53 SET X=$$ASKFLD("58.400111,.06",$PIECE($GET(ALLASAP(SEGID,ELMPOS)),"^",6))
IF X="^"
QUIT
+54 SET ELMREQ=X
+55 ; Data Element M Expression
+56 SET MEXPR=""
FOR I=1:1
if '$DATA(ALLASAP(SEGID,ELMPOS,"VAL",I))
QUIT
Begin DoDot:2
+57 SET MEXPR=MEXPR_ALLASAP(SEGID,ELMPOS,"VAL",I)
End DoDot:2
+58 SET X=$$ASKMEXPR($PIECE(ALLASAP(SEGID),"^",6),CUSELM,MAXLEN,MEXPR)
IF X="^"
QUIT
+59 SET MEXPR=X
+60 WRITE !
SET X=$$ASKFLD("Y","YES","Save Custom Data Element")
IF X'=1
QUIT
+61 WRITE ?40,"Saving..."
+62 ; If first time the Data Element is being customized, copy; otherwise save
+63 IF '$DATA(CUSASAP(SEGID,ELMPOS))
Begin DoDot:2
+64 ; The Custom ASAP Segment node might not be present (1st time), therefore it must be created
+65 IF '$DATA(CUSASAP(SEGID))
DO COPYSEG^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,SEGID)
+66 ; PSO*7*772
IF $$CLONE^PSOSPML3(PSOASVER)
DO CUSTDEL^PSOSPMU2(PSOASVER,SEGID,ELMPOS,ELMDATA,.STDASAP)
+67 SET $PIECE(STDASAP(SEGID,ELMPOS),"^",4)=MAXLEN
+68 SET $PIECE(STDASAP(SEGID,ELMPOS),"^",6)=ELMREQ
+69 SET STDASAP(SEGID,ELMPOS,"VAL",1)=MEXPR
+70 KILL STDASAP(SEGID,ELMPOS,"DES")
MERGE STDASAP(SEGID,ELMPOS,"DES")=ELMDATA("DES")
+71 DO COPYELM^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,CUSELM)
End DoDot:2
+72 IF $DATA(CUSASAP(SEGID,ELMPOS))
Begin DoDot:2
+73 ; PSO*7*772
IF $$CLONE^PSOSPML3(PSOASVER)
DO CUSTDEL^PSOSPMU2(PSOASVER,SEGID,ELMPOS,ELMDATA,.CUSASAP)
+74 SET $PIECE(CUSASAP(SEGID,ELMPOS),"^",4)=MAXLEN
+75 SET $PIECE(CUSASAP(SEGID,ELMPOS),"^",6)=ELMREQ
+76 SET CUSASAP(SEGID,ELMPOS,"VAL",1)=MEXPR
+77 KILL CUSASAP(SEGID,ELMPOS,"DES")
MERGE CUSASAP(SEGID,ELMPOS,"DES")=ELMDATA("DES")
+78 ; If legacy standard (not standard copy), reset element values
KILL ELMDATA
MERGE ELMDATA=CUSASAP(SEGID,ELMPOS)
+79 DO SAVEELM^PSOSPMU3(PSOASVER,SEGID,CUSELM,.ELMDATA,$GET(CLONE))
End DoDot:2
+80 WRITE "OK",$CHAR(7)
End DoDot:1
+81 IF '$DATA(STDASAP(SEGID,ELMPOS))
Begin DoDot:1
+82 KILL ELMDATA
SET (Y,NEWELM)=0
+83 IF '$DATA(CUSASAP(SEGID,ELMPOS))
Begin DoDot:2
+84 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
+85 SET NEWELM=1
WRITE !
End DoDot:2
IF $DATA(DIRUT)!$DATA(DTOUT)!'Y
QUIT
+86 ; Data Element ID and Position are non-editable fields
+87 SET $PIECE(ELMDATA,"^",1)=CUSELM
+88 SET $PIECE(ELMDATA,"^",5)=ELMPOS
+89 ; Data Element Name
+90 SET X=$$ASKFLD("58.400111,.02",$PIECE($GET(CUSASAP(SEGID,ELMPOS)),"^",2))
IF X="^"
QUIT
+91 SET $PIECE(ELMDATA,"^",2)=X
+92 ; Data Element Format
+93 SET X=$$ASKFLD("58.400111,.03",$PIECE($GET(CUSASAP(SEGID,ELMPOS)),"^",3))
IF X="^"
QUIT
+94 SET $PIECE(ELMDATA,"^",3)=X
+95 ; Data Element Maximum Length
+96 SET X=$$ASKFLD("58.400111,.04",$PIECE($GET(CUSASAP(SEGID,ELMPOS)),"^",4))
IF X="^"
QUIT
+97 SET $PIECE(ELMDATA,"^",4)=X
+98 ; Data Element Requirement
+99 SET X=$$ASKFLD("58.400111,.06",$PIECE($GET(CUSASAP(SEGID,ELMPOS)),"^",6))
IF X="^"
QUIT
+100 SET $PIECE(ELMDATA,"^",6)=X
+101 ; Data Element Description
+102 WRITE !,"DESCRIPTION:"
KILL ^TMP("PSOASDES",$JOB)
+103 ; Transferring Description from Local Array ALLASAP to ^TMP($J)
+104 FOR I=1:1
if '$DATA(ALLASAP(SEGID,ELMPOS,"DES",I))
QUIT
Begin DoDot:2
+105 SET ^TMP("PSOASDES",$JOB,I,0)=ALLASAP(SEGID,ELMPOS,"DES",I)
End DoDot:2
+106 KILL DIC
SET DWPK=1
SET DIC="^TMP(""PSOASDES"","_$JOB_","
DO EN^DIWE
+107 ; Transferring Description from ^TMP($J) to Local Array CUSASAP
+108 FOR I=1:1
if '$DATA(^TMP("PSOASDES",$JOB,I,0))
QUIT
Begin DoDot:2
+109 SET ELMDATA("DES",I)=^TMP("PSOASDES",$JOB,I,0)
End DoDot:2
+110 ; Data Element M Expression
+111 SET DONE=0
SET MEXPR=""
+112 FOR I=1:1
if '$DATA(ALLASAP(SEGID,ELMPOS,"VAL",I))
QUIT
Begin DoDot:2
+113 SET MEXPR=MEXPR_ALLASAP(SEGID,ELMPOS,"VAL",I)
End DoDot:2
+114 SET X=$$ASKMEXPR($PIECE(ALLASAP(SEGID),"^",6),CUSELM,$PIECE(ELMDATA,"^",4),MEXPR)
IF X="^"
QUIT
+115 SET ELMDATA("VAL",1)=X
+116 ; Confirm
+117 WRITE !
SET X=$$ASKFLD("Y","YES","Save Custom Data Element")
IF X'=1
QUIT
+118 WRITE ?40,"Saving..."
+119 ; The Custom ASAP Segment node might not be present, therefore it must be created
+120 IF $GET(CUSASAP(SEGID))=""
DO COPYSEG^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,SEGID)
+121 DO SAVEELM^PSOSPMU3(PSOASVER,SEGID,$SELECT(NEWELM:"+1",1:CUSELM),.ELMDATA)
+122 WRITE "OK",$CHAR(7)
End DoDot:1
+123 GOTO CEL
+124 ;
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
