- 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 Feb 19, 2025@00:01:23 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