- PSOSPMU3 ;BIRM/MFR - State Prescription Monitoring Program Utility #3 - Customization ;10/07/15
- ;;7.0;OUTPATIENT PHARMACY;**451,625**;DEC 1997;Build 42
- ;
- CLONEVER(FROMVER,NEWVER,DEFTYPE) ; Create an exact copy of another ASAP version
- ;Input: (r) FROMVER - Source ASAP Version to be cloned (3.0, 4.0, 4.1, 4.2)
- ; (r) NEWVER - New ASAP Version to be created (4.3, 4.4, 5.0, etc...)
- ; (r) DEFTYPE - ASAP Definition Type (S: Standard Only; C: Customized Only, B: Both)
- I $G(FROMVER)=""!($G(NEWVER)="") Q
- N CUSIEN,ASAPVER,ASAPDEF,NWVERIEN,SEGID,SEGIEN,ELMPOS,ELMID,ELMIEN
- S CUSIEN=$O(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
- ; New ASAP Version already exists
- I $D(^PS(58.4,CUSIEN,"VER","B",NEWVER)) Q
- D LOADASAP^PSOSPMU0(FROMVER,DEFTYPE,.ASAPDEF)
- S NWVERIEN=$$SAVEVER(NEWVER,.ASAPDEF) I NWVERIEN'>0 Q
- ;
- S SEGID="999"
- F S SEGID=$O(ASAPDEF(SEGID)) Q:SEGID="" D
- . S SEGIEN=$$COPYSEG(FROMVER,.ASAPDEF,NEWVER,SEGID) I SEGIEN'>0 Q
- . S ELMPOS=""
- . F S ELMPOS=$O(ASAPDEF(SEGID,ELMPOS)) Q:ELMPOS="" D
- . . S ELMID=$P(ASAPDEF(SEGID,ELMPOS),"^")
- . . S ELMIEN=$$COPYELM(FROMVER,.ASAPDEF,NEWVER,ELMID)
- Q
- ;
- SAVEVER(ASAPVER,VERDATA) ; Save an ASAP Version
- ;Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.)
- ; (r) VERDATA - ASAP Version Data
- ;Output: SAVVER - ASAP Version IEN
- I $G(ASAPVER)=""!($G(VERDATA)="") Q "-1^Invalid Input Parameters"
- N SAVEVER,CUSIEN,VERIEN,VERDEF
- S CUSIEN=$O(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0)) I 'CUSIEN Q "-1^Invalid Custom ASAP Data Definition"
- ; If Custom ASAP Version entry does not exist, create it
- S VERIEN=$O(^PS(58.4,CUSIEN,"VER","B",ASAPVER,0)) I 'VERIEN S VERIEN="+1"
- ;
- S VERDEF(58.4001,VERIEN_","_CUSIEN_",",.01)=ASAPVER
- S VERDEF(58.4001,VERIEN_","_CUSIEN_",",.02)=$P(VERDATA,"^",2)
- S VERDEF(58.4001,VERIEN_","_CUSIEN_",",.03)=$P(VERDATA,"^",3)
- S VERDEF(58.4001,VERIEN_","_CUSIEN_",",.04)=$P(VERDATA,"^",4)
- S VERDEF(58.4001,VERIEN_","_CUSIEN_",",.05)=$P(VERDATA,"^",5) ;Denotes Zero Report Version
- D UPDATE^DIE("","VERDEF","SAVEVER","")
- S:VERIEN="+1" VERIEN=+$G(SAVEVER(1))
- ; Necessary to force the '@' as a delimiter/terminator
- I $P(VERDATA,"^",2)="@",VERIEN S $P(^PS(58.4,CUSIEN,"VER",VERIEN,0),"^",2)="@"
- I $P(VERDATA,"^",3)="@",VERIEN S $P(^PS(58.4,CUSIEN,"VER",VERIEN,0),"^",3)="@"
- Q VERIEN
- ;
- COPYSEG(FROMVER,ASAPDEF,TOVER,SEGID) ; Copy a Segment
- ; Input: (r) FROMVER - Source ASAP Version ("3.0", "4.0", etc.)
- ; (r) ASAPDEF - Array containig the ASAP Definition to be copied
- ; (r) TOMVER - Detin ASAP Version ("3.0", "4.0", etc.)
- ; (r) SEGID - Segment ID ("PHA", "DSP", etc.)
- ;Output: SAVESEG - New Segment IEN
- I $G(FROMVER)=""!($G(TOVER)="")!($G(SEGID)="") Q "-1^Invalid Input Parameters"
- N STDIEN,CUSIEN,TOVERIEN,SEGDEF,SEGIEN
- S STDIEN=$O(^PS(58.4,"B","STANDARD ASAP DEFINITION",0))
- S CUSIEN=$O(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
- ; From ASAP Version must exist (Standard or Custom)
- I '$D(^PS(58.4,STDIEN,"VER","B",FROMVER)),'$D(^PS(58.4,CUSIEN,"VER","B",FROMVER)) Q "-1^Source ASAP Version does not exist."
- ; To ASAP Version must exist (Custom) - If not, try to create it
- S TOVERIEN=$O(^PS(58.4,CUSIEN,"VER","B",TOVER,9999),-1)
- I 'TOVERIEN S TOVERIEN=$$SAVEVER(TOVER,ASAPDEF) I TOVERIEN<0 Q TOVERIEN
- ; Segment ID already on file (cannot be copied again)
- I $O(^PS(58.4,CUSIEN,"VER",TOVERIEN,"SEG","B",SEGID,0)) Q "-1^Segment ID already on file"
- I '$D(ASAPDEF(SEGID)) Q "-1^Missing new segment data"
- Q $$SAVESEG(TOVER,"+1",ASAPDEF(SEGID),ASAPDEF)
- ;
- SAVESEG(ASAPVER,SEGID,SEGDATA,VERDATA) ; Saves a Segment
- ; Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.)
- ; (r) SEGID - Segment ID ("PHA", "DSP", etc.) or "+1" to add a new Segment
- ; (r) SEGDATA - Segment Data
- ; (o) VERDATA - Version Data (Only needed for 1st custom segment)
- ;Output: SAVESEG - Segment IEN
- I $G(ASAPVER)=""!($G(SEGID)="")!($G(SEGDATA)="") Q "-1^Invalid Input Parameters"
- N SAVESEG,CUSIEN,VERIEN,SEGIEN,SEGDEF
- S CUSIEN=$O(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0)) I 'CUSIEN Q "-1^Invalid Custom ASAP Data Definition"
- ; Custom ASAP Version must exist - If not, create it
- S VERIEN=$O(^PS(58.4,CUSIEN,"VER","B",ASAPVER,9999),-1)
- I 'VERIEN S VERIEN=$$SAVEVER(ASAPVER,VERDATA) I VERIEN<0 Q "-1^Invalid Custom ASAP Version"
- S SEGIEN=SEGID
- I SEGIEN'="+1" S SEGIEN=$O(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG","B",SEGID,9999),-1) I 'SEGIEN Q "-1^Invalid Custom ASAP Segment"
- S SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.01)=$P(SEGDATA,"^",1) ;Segment ID
- S SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.02)=$P(SEGDATA,"^",2) ;Segment Name
- S SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.03)=$P(SEGDATA,"^",3) ;Parent Segment
- S SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.04)=$P(SEGDATA,"^",4) ;Requirement
- S SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.05)=$P(SEGDATA,"^",5) ;Position
- S SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.06)=$P(SEGDATA,"^",6) ;Level
- D UPDATE^DIE("","SEGDEF","SAVESEG","")
- I SEGIEN="+1" S SEGIEN=+$G(SAVESEG(1))
- Q SEGIEN
- ;
- COPYELM(FROMVER,ASAPDEF,TOVER,ELMID) ; Copy a Data Element
- ;Input: (r) FROMVER - Source ASAP Version ("3.0", "4.0", etc.)
- ; (r) ASAPDEF - Array containig the ASAP Definition to be copied
- ; (r) TOMVER - Detin ASAP Version ("3.0", "4.0", etc.)
- ; (r) ELMID - Data Element ID ("PHA01", "DSP02", etc.)
- ;Output: SAVESEG - Segment IEN
- I $G(FROMVER)=""!'$D(ASAPDEF)!($G(TOVER)="")!($G(ELMID)="") Q "-1^Invalid Input Parameters"
- N STDIEN,CUSIEN,TOVERIEN,TOSEGIEN,ELMDEF,ELMIEN,ELMDATA
- S STDIEN=$O(^PS(58.4,"B","STANDARD ASAP DEFINITION",0))
- S CUSIEN=$O(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
- ; From ASAP Version must exist (Standard or Custom)
- I '$D(^PS(58.4,STDIEN,"VER","B",FROMVER)),'$D(^PS(58.4,CUSIEN,"VER","B",FROMVER)) Q "-1^Source ASAP Version does not exist."
- ; To ASAP Version must exist (Custom) - If not, create it
- S TOVERIEN=$O(^PS(58.4,CUSIEN,"VER","B",TOVER,9999),-1)
- I 'TOVERIEN S TOVERIEN=$$SAVEVER(TOVER,ASAPDEF) I TOVERIEN<0 Q "-1^Invalid Custom ASAP Version"
- S SEGID=$$GETSEGID(ELMID) I SEGID="" Q "-1^Invalid Segment ID "_SEGID_"."
- ; Custom ASAP Segment must exist - If not, create it
- S TOSEGIEN=$O(^PS(58.4,CUSIEN,"VER",TOVERIEN,"SEG","B",SEGID,9999),-1)
- I 'TOSEGIEN S TOSEGIEN=$$SAVESEG(TOVER,SEGID,ASAPDEF(SEGID),ASAPDEF) I 'TOSEGIEN Q "-1^Segment ID does not exist in the destin ASAP Version."
- ; Segment ID already on file (cannot be copied again)
- I $O(^PS(58.4,CUSIEN,"VER",TOVERIEN,"SEG",TOSEGIEN,"DAT","B",ELMID,9999),-1) Q "-1^Data Element already on file"
- I '$D(ASAPDEF(SEGID,ELMPOS)) Q "-1^Data Element does not exist in the source ASAP Version."
- K ELMDATA M ELMDATA=ASAPDEF(SEGID,ELMPOS)
- Q $$SAVEELM(TOVER,SEGID,"+1",.ELMDATA)
- ;
- SAVEELM(ASAPVER,SEGID,ELMID,ELMDATA) ; Saves a Data Element
- ;Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.)
- ; (r) SEGID - Segment ID ("PHA", "DSP", etc.)
- ; (r) ELMID - Data Element ID ("PHA01", "DSP05", etc.) or "+1" to add a new Data Element
- ; (r) ELMDATA - Data Element Data
- ;Output: SAVEELM - Data Element IEN
- I $G(ASAPVER)=""!($G(SEGID)="")!($G(ELMID)="")!($G(ELMDATA)="") Q "-1^Invalid Input Parameters"
- N SAVEELM,CUSIEN,VERIEN,ELMIEN,ELMDEF,SEGIEN
- S CUSIEN=$O(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0)) I 'CUSIEN Q "-1^Invalid Custom ASAP Data Definition"
- ; Custom ASAP Version must exist
- S VERIEN=$O(^PS(58.4,CUSIEN,"VER","B",ASAPVER,9999),-1) I 'VERIEN Q "-1^Invalid Custom ASAP Version"
- ; Custom ASAP Segment must exist
- S SEGIEN=$O(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG","B",SEGID,9999),-1) I 'SEGIEN Q "-1^Segment ID does not exist in the destin ASAP Version."
- S ELMIEN=ELMID
- I ELMIEN'="+1" S ELMIEN=$O(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG",SEGIEN,"DAT","B",ELMID,9999),-1) I 'ELMIEN Q "-1^Invalid Custom ASAP Data Element"
- ; Saving Data Element
- S ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.01)=$P(ELMDATA,"^",1) ;Element ID
- S ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.02)=$P(ELMDATA,"^",2) ;Element Name
- S ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.03)=$P(ELMDATA,"^",3) ;Data Format
- S ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.04)=$P(ELMDATA,"^",4) ;Maximum Length
- S ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.05)=$P(ELMDATA,"^",5) ;Position
- S ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.06)=$P(ELMDATA,"^",6) ;Requirement
- S ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.07)="ELMDATA(""DES"")" ;Description
- S ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.08)="ELMDATA(""VAL"")" ;Value
- D UPDATE^DIE("","ELMDEF","SAVEELM","")
- I ELMIEN="+1" S ELMIEN=+$G(SAVEELM(1))
- Q ELMIEN
- ;
- CUSSEG(ASAPVER,SEGID) ; Customized Segment?
- ;Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.)
- ; (r) SEGID - Segment ID
- ;Output: Customized Segment? 1: YES / 0: NO
- I $G(ASAPVER)=""!($G(SEGID)="") Q 0
- N STDASAP,CUSASAP
- D LOADASAP^PSOSPMU0(ASAPVER,"S",.STDASAP) ; Standard ASAP Definition
- D LOADASAP^PSOSPMU0(ASAPVER,"C",.CUSASAP) ; Custom ASAP Definition
- I $G(CUSASAP(SEGID))="" Q 0
- I $G(STDASAP(SEGID))=$G(CUSASAP(SEGID)) Q 0
- Q 1
- ;
- DELCUS(ASAPVER,SEGID,ELMID) ; Delete/Reset a Customization
- ;Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.)
- ; (o) SEGID - Segment ID ("PHA", "DSP", etc.)
- ; (o) ELMID - Data Element ID ("PHA01", "DSP02", etc.)
- I $G(ASAPVER)="" Q
- N STDASAP,CUSASAP,CUSIEN,VERIEN,SEGIEN,ELMIEN,DIK,DA
- D LOADASAP^PSOSPMU0(ASAPVER,"S",.STDASAP) ; Standard ASAP Definition
- D LOADASAP^PSOSPMU0(ASAPVER,"C",.CUSASAP) ; Custom ASAP Definition
- ;
- S CUSIEN=$O(^PS(58.4,"B","CUSTOM ASAP DEFINITION",9999),-1)
- S VERIEN=$O(^PS(58.4,CUSIEN,"VER","B",ASAPVER,9999),-1) I 'VERIEN Q
- I $G(SEGID)'="" D
- . S SEGIEN=$O(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG","B",SEGID,9999),-1)
- I $G(ELMID)'="" D
- . S SEGIEN=$O(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG","B",$$GETSEGID(ELMID),9999),-1) I 'SEGIEN Q
- . S ELMIEN=$O(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG",SEGIEN,"DAT","B",ELMID,9999),-1)
- ;
- I $G(SEGID)'="",'$G(SEGIEN) Q
- I $G(ELMID)'="",'$G(ELMIEN) Q
- ;
- ; Deleting/Resetting a Custom Data Element
- I $G(ELMID)'="" D Q
- . S DIK="^PS(58.4,"_CUSIEN_",""VER"","_VERIEN_",""SEG"","_SEGIEN_",""DAT"","
- . S DA(3)=CUSIEN,DA(2)=VERIEN,DA(1)=SEGIEN,DA=ELMIEN D ^DIK
- ;
- ; Deleting/Resetting an Entire Custom Segment
- I $G(SEGID)'="" D Q
- . S DIK="^PS(58.4,"_CUSIEN_",""VER"","_VERIEN_",""SEG"","
- . S DA(2)=CUSIEN,DA(1)=VERIEN,DA=SEGIEN D ^DIK
- ;
- ; Deleting/Resetting an Entire Custom ASAP Version
- S DIK="^PS(58.4,"_CUSIEN_",""VER"","
- S DA(1)=CUSIEN,DA=VERIEN D ^DIK
- Q
- ;
- GETSEGID(ELMID) ; Get the Segment ID from the Element ID
- ;Input: (r) ELMID - Data Element ID ("PHA01", "DSP02", etc.)
- N GETSEGID,I
- S GETSEGID=$G(ELMID) F I=$L(ELMID):-1:1 Q:($E(ELMID,I)'?1N) S $E(GETSEGID,I)=""
- Q GETSEGID
- ;
- VALID(ASAPVER,MEXPR) ; Validate the Mumps Expression for the ASAP Version
- ;Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.) (Required for checking the delimiters)
- ; (r) MEXPR - M SET Expression Argument to be validated
- I $G(ASAPVER)=""!($G(MEXPR)="") Q "0^Invalid Input Parameters"
- N VALID,VERDATA,ELMDELIM,SEGDELIM,INQUOTES,CHAR,X,I
- S MEXPR=$$UP^XLFSTR(MEXPR)
- I $G(MEXPR)="" Q "0^M SET Expression cannot be empty. Use """" for blank/null values."
- I $F(MEXPR," D ^")!$F(MEXPR," DO ^")!$F(MEXPR,"G ^")!$F(MEXPR,"GO ^") Q "0^M SET Expression cannot call out other routines."
- I $F(MEXPR,"K ^")!$F(MEXPR,"KILL ^") Q "0^M SET Expression cannot contain 'KILL' command."
- I $F(MEXPR," S ^")!$F(MEXPR," SET ^") Q "0^M SET Expression cannot contain 'SET' command."
- I $F(MEXPR," L +")!$F(MEXPR," L ^")!$F(MEXPR," LOCK ") Q "0^M SET Expression cannot contain 'LOCK' command."
- I $F(MEXPR,"$C(") Q "0^M SET Expression cannot contain special characters ($C)."
- S VALID=1,VERDATA=$$VERDATA^PSOSPMU0(ASAPVER,"B")
- S ELMDELIM=$P(VERDATA,"^",2),SEGDELIM=$P(VERDATA,"^",3)
- S INQUOTES=0
- F I=1:1:$L(MEXPR) D I VALID<0 Q
- . S CHAR=$E(MEXPR,I)
- . I ($A(CHAR)<32)!($A(CHAR)>176) S VALID="0^M SET Expression cannot contain special characters." Q
- . I CHAR="""" S INQUOTES=((INQUOTES+1)#2)
- . I INQUOTES D
- . . I CHAR=ELMDELIM S VALID="0^M SET Expression Cannot contain the character '"_CHAR_"' (Element Delimiter)." Q
- . . I CHAR=SEGDELIM S VALID="0^M SET Expression Cannot contain the character '"_CHAR_"' (Segment Terminator)." Q
- . E D
- . . I CHAR=" " S VALID="0^No Blank Space characters allowed outside quotes." Q
- ; The concatenated 'X' below is for security purposes
- S X="W "_MEXPR_"_""X""" D ^DIM I '$D(X) Q "0^M SET Expression syntax is invalid."
- Q VALID
- ;
- CHKVAR(LEVEL,MEXPR) ; Checks the variables in the M SET Expression
- ; Input: (r) LEVEL - Level of the Segment where the Data Element is located
- ; (r) MEXPR - Mumps SET Expression value to be verified
- ;Output: $$CHKVAR - 1: No issues / 0: Invalid Variable use
- I '$G(LEVEL)!$G(MEXPR)="" Q 1
- N CHKVAR,LEVNAM,VAR,OKLST
- S CHKVAR=""
- I LEVEL=4 Q 1
- I LEVEL=1!(LEVEL=6) S OKLST="STATEIEN,"
- I LEVEL=2!(LEVEL=5) S OKLST="STATEIEN,SITEIEN,"
- I LEVEL=3 S OKLST="STATEIEN,SITEIEN,PATIEN"
- F VAR="STATEIEN","SITEIEN","PATIEN","RXIEN","DRUGIEN","FILLNUM","FILLIEN","RPHIEN","PREIEN","RTSREC" D
- . I MEXPR[VAR,OKLST'[VAR S CHKVAR=CHKVAR_$S(CHKVAR'="":",",1:"")_VAR
- I CHKVAR'="" D Q 0
- . S LEVNAM=$P("MAIN HEADER^PHARMACY HEADER^PATIENT DETAIL^PRESCRIPTION DETAIL^PHARMACY TRAILER^MAIN TRAILER","^",LEVEL)
- . W !,"The variable",$S(CHKVAR[",":"s",1:"")," ",CHKVAR," ",$S(CHKVAR[",":"are",1:"is")," not available at the ",LEVNAM," level.",$C(7),!
- Q 1
- ;
- CHKCODE(LEVEL,MEXPR,ERROR) ; Checks the data retrieval code for the Data Element
- ; Input: (r) LEVEL - Level of the Segment where the Data Element is located
- ; (r) MEXPR - Mumps SET Expression value to be verified
- ;Output: ERROR - Indicate whether an ERROR occurred or not (1: Yes, 0: No)
- I '$G(LEVEL)!$G(MEXPR)="" Q
- N QUIT,STATEIEN,SITEIEN,LASTRD,PATIEN,DFN,RXIEN,DRUGIEN,FILLIEN,FILLNUM,PREIEN,RPHIEN,RTSREC,CODE,X
- N RECTYPE
- S ERROR=0
- I '$G(LEVEL)!$G(MEXPR)="" Q
- S (QUIT,SITEIEN,PATIEN,DFN,RXIEN,DRUGIEN,FILLIEN,PREIEN,RPHIEN,FILLNUM,RTSREC)=0
- D I QUIT Q
- . S LASTRD=$O(^PSRX("AL",9999999),-1) I 'LASTRD S QUIT=1 Q
- . S RXIEN=$O(^PSRX("AL",LASTRD,0)) I '$D(^PSRX(RXIEN,0)) S QUIT=1 Q
- . S SITEIEN=$$RXSITE^PSOBPSUT(RXIEN,0)
- . S STATEIEN=$$GET1^DIQ(59,SITEIEN,.08,"I")
- . I LEVEL=1!(LEVEL=6) K SITEIEN,PATIEN,DFN,RXIEN,DRUGIEN,FILLIEN,FILLNUM,PREIEN,RPHIEN,RTSREC Q
- . I LEVEL=2!(LEVEL=5) K PATIEN,DFN,RXIEN,DRUGIEN,FILLIEN,FILLNUM,PREIEN,RPHIEN,RTSREC Q
- . S (PATIEN,DFN)=$$GET1^DIQ(52,RXIEN,2,"I") D SETNAME^PSOSPMUT(PATIEN)
- . I LEVEL=3 K RXIEN,DRUGIEN,FILLIEN,FILLNUM,PREIEN,RPHIEN,RTSREC Q
- . S DRUGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
- . S FILLIEN=0,FILLNUM=0,RECTYPE="N"
- . S PREIEN=$$RXPRV^PSOBPSUT(RXIEN,0)
- . S RPHIEN=$$RXRPH^PSOBPSUT(RXIEN,0)
- S CODE="S X="_MEXPR
- N $ETRAP,$ESTACK S $ETRAP="D ERROR^PSOSPMU3"
- X CODE
- Q
- ;
- ERROR ; Error Trap to test ASAP Data Retrieval
- N ZE,DIR,DRUT,DTOUT,X,Y
- S ZE=$$EC^%ZOSV
- I ZE["<UNDEFINED>" D
- . W !,"The code will likely throw an <UNDEFINED> error for the "
- . W $S(ZE["*":"variable '",1:"global ^"),$S(ZE["*":$P(ZE,"*",2)_"'",1:$P(ZE,"^",3)),".",$C(7)
- . S DIR(0)="Y",DIR("B")="NO",DIR("A")="Continue Anyway" D ^DIR I '$G(Y) S ERROR=1
- E W !,"The code will throw a <",$P($P(ZE,"<",2),">"),"> error for this expression.",$C(7) S ERROR=1
- ; Continue on
- W ! G UNWIND^%ZTER
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSPMU3 15699 printed Jan 18, 2025@03:36:22 Page 2
- PSOSPMU3 ;BIRM/MFR - State Prescription Monitoring Program Utility #3 - Customization ;10/07/15
- +1 ;;7.0;OUTPATIENT PHARMACY;**451,625**;DEC 1997;Build 42
- +2 ;
- CLONEVER(FROMVER,NEWVER,DEFTYPE) ; Create an exact copy of another ASAP version
- +1 ;Input: (r) FROMVER - Source ASAP Version to be cloned (3.0, 4.0, 4.1, 4.2)
- +2 ; (r) NEWVER - New ASAP Version to be created (4.3, 4.4, 5.0, etc...)
- +3 ; (r) DEFTYPE - ASAP Definition Type (S: Standard Only; C: Customized Only, B: Both)
- +4 IF $GET(FROMVER)=""!($GET(NEWVER)="")
- QUIT
- +5 NEW CUSIEN,ASAPVER,ASAPDEF,NWVERIEN,SEGID,SEGIEN,ELMPOS,ELMID,ELMIEN
- +6 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
- +7 ; New ASAP Version already exists
- +8 IF $DATA(^PS(58.4,CUSIEN,"VER","B",NEWVER))
- QUIT
- +9 DO LOADASAP^PSOSPMU0(FROMVER,DEFTYPE,.ASAPDEF)
- +10 SET NWVERIEN=$$SAVEVER(NEWVER,.ASAPDEF)
- IF NWVERIEN'>0
- QUIT
- +11 ;
- +12 SET SEGID="999"
- +13 FOR
- SET SEGID=$ORDER(ASAPDEF(SEGID))
- if SEGID=""
- QUIT
- Begin DoDot:1
- +14 SET SEGIEN=$$COPYSEG(FROMVER,.ASAPDEF,NEWVER,SEGID)
- IF SEGIEN'>0
- QUIT
- +15 SET ELMPOS=""
- +16 FOR
- SET ELMPOS=$ORDER(ASAPDEF(SEGID,ELMPOS))
- if ELMPOS=""
- QUIT
- Begin DoDot:2
- +17 SET ELMID=$PIECE(ASAPDEF(SEGID,ELMPOS),"^")
- +18 SET ELMIEN=$$COPYELM(FROMVER,.ASAPDEF,NEWVER,ELMID)
- End DoDot:2
- End DoDot:1
- +19 QUIT
- +20 ;
- SAVEVER(ASAPVER,VERDATA) ; Save an ASAP Version
- +1 ;Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.)
- +2 ; (r) VERDATA - ASAP Version Data
- +3 ;Output: SAVVER - ASAP Version IEN
- +4 IF $GET(ASAPVER)=""!($GET(VERDATA)="")
- QUIT "-1^Invalid Input Parameters"
- +5 NEW SAVEVER,CUSIEN,VERIEN,VERDEF
- +6 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
- IF 'CUSIEN
- QUIT "-1^Invalid Custom ASAP Data Definition"
- +7 ; If Custom ASAP Version entry does not exist, create it
- +8 SET VERIEN=$ORDER(^PS(58.4,CUSIEN,"VER","B",ASAPVER,0))
- IF 'VERIEN
- SET VERIEN="+1"
- +9 ;
- +10 SET VERDEF(58.4001,VERIEN_","_CUSIEN_",",.01)=ASAPVER
- +11 SET VERDEF(58.4001,VERIEN_","_CUSIEN_",",.02)=$PIECE(VERDATA,"^",2)
- +12 SET VERDEF(58.4001,VERIEN_","_CUSIEN_",",.03)=$PIECE(VERDATA,"^",3)
- +13 SET VERDEF(58.4001,VERIEN_","_CUSIEN_",",.04)=$PIECE(VERDATA,"^",4)
- +14 ;Denotes Zero Report Version
- SET VERDEF(58.4001,VERIEN_","_CUSIEN_",",.05)=$PIECE(VERDATA,"^",5)
- +15 DO UPDATE^DIE("","VERDEF","SAVEVER","")
- +16 if VERIEN="+1"
- SET VERIEN=+$GET(SAVEVER(1))
- +17 ; Necessary to force the '@' as a delimiter/terminator
- +18 IF $PIECE(VERDATA,"^",2)="@"
- IF VERIEN
- SET $PIECE(^PS(58.4,CUSIEN,"VER",VERIEN,0),"^",2)="@"
- +19 IF $PIECE(VERDATA,"^",3)="@"
- IF VERIEN
- SET $PIECE(^PS(58.4,CUSIEN,"VER",VERIEN,0),"^",3)="@"
- +20 QUIT VERIEN
- +21 ;
- COPYSEG(FROMVER,ASAPDEF,TOVER,SEGID) ; Copy a Segment
- +1 ; Input: (r) FROMVER - Source ASAP Version ("3.0", "4.0", etc.)
- +2 ; (r) ASAPDEF - Array containig the ASAP Definition to be copied
- +3 ; (r) TOMVER - Detin ASAP Version ("3.0", "4.0", etc.)
- +4 ; (r) SEGID - Segment ID ("PHA", "DSP", etc.)
- +5 ;Output: SAVESEG - New Segment IEN
- +6 IF $GET(FROMVER)=""!($GET(TOVER)="")!($GET(SEGID)="")
- QUIT "-1^Invalid Input Parameters"
- +7 NEW STDIEN,CUSIEN,TOVERIEN,SEGDEF,SEGIEN
- +8 SET STDIEN=$ORDER(^PS(58.4,"B","STANDARD ASAP DEFINITION",0))
- +9 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
- +10 ; From ASAP Version must exist (Standard or Custom)
- +11 IF '$DATA(^PS(58.4,STDIEN,"VER","B",FROMVER))
- IF '$DATA(^PS(58.4,CUSIEN,"VER","B",FROMVER))
- QUIT "-1^Source ASAP Version does not exist."
- +12 ; To ASAP Version must exist (Custom) - If not, try to create it
- +13 SET TOVERIEN=$ORDER(^PS(58.4,CUSIEN,"VER","B",TOVER,9999),-1)
- +14 IF 'TOVERIEN
- SET TOVERIEN=$$SAVEVER(TOVER,ASAPDEF)
- IF TOVERIEN<0
- QUIT TOVERIEN
- +15 ; Segment ID already on file (cannot be copied again)
- +16 IF $ORDER(^PS(58.4,CUSIEN,"VER",TOVERIEN,"SEG","B",SEGID,0))
- QUIT "-1^Segment ID already on file"
- +17 IF '$DATA(ASAPDEF(SEGID))
- QUIT "-1^Missing new segment data"
- +18 QUIT $$SAVESEG(TOVER,"+1",ASAPDEF(SEGID),ASAPDEF)
- +19 ;
- SAVESEG(ASAPVER,SEGID,SEGDATA,VERDATA) ; Saves a Segment
- +1 ; Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.)
- +2 ; (r) SEGID - Segment ID ("PHA", "DSP", etc.) or "+1" to add a new Segment
- +3 ; (r) SEGDATA - Segment Data
- +4 ; (o) VERDATA - Version Data (Only needed for 1st custom segment)
- +5 ;Output: SAVESEG - Segment IEN
- +6 IF $GET(ASAPVER)=""!($GET(SEGID)="")!($GET(SEGDATA)="")
- QUIT "-1^Invalid Input Parameters"
- +7 NEW SAVESEG,CUSIEN,VERIEN,SEGIEN,SEGDEF
- +8 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
- IF 'CUSIEN
- QUIT "-1^Invalid Custom ASAP Data Definition"
- +9 ; Custom ASAP Version must exist - If not, create it
- +10 SET VERIEN=$ORDER(^PS(58.4,CUSIEN,"VER","B",ASAPVER,9999),-1)
- +11 IF 'VERIEN
- SET VERIEN=$$SAVEVER(ASAPVER,VERDATA)
- IF VERIEN<0
- QUIT "-1^Invalid Custom ASAP Version"
- +12 SET SEGIEN=SEGID
- +13 IF SEGIEN'="+1"
- SET SEGIEN=$ORDER(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG","B",SEGID,9999),-1)
- IF 'SEGIEN
- QUIT "-1^Invalid Custom ASAP Segment"
- +14 ;Segment ID
- SET SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.01)=$PIECE(SEGDATA,"^",1)
- +15 ;Segment Name
- SET SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.02)=$PIECE(SEGDATA,"^",2)
- +16 ;Parent Segment
- SET SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.03)=$PIECE(SEGDATA,"^",3)
- +17 ;Requirement
- SET SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.04)=$PIECE(SEGDATA,"^",4)
- +18 ;Position
- SET SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.05)=$PIECE(SEGDATA,"^",5)
- +19 ;Level
- SET SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.06)=$PIECE(SEGDATA,"^",6)
- +20 DO UPDATE^DIE("","SEGDEF","SAVESEG","")
- +21 IF SEGIEN="+1"
- SET SEGIEN=+$GET(SAVESEG(1))
- +22 QUIT SEGIEN
- +23 ;
- COPYELM(FROMVER,ASAPDEF,TOVER,ELMID) ; Copy a Data Element
- +1 ;Input: (r) FROMVER - Source ASAP Version ("3.0", "4.0", etc.)
- +2 ; (r) ASAPDEF - Array containig the ASAP Definition to be copied
- +3 ; (r) TOMVER - Detin ASAP Version ("3.0", "4.0", etc.)
- +4 ; (r) ELMID - Data Element ID ("PHA01", "DSP02", etc.)
- +5 ;Output: SAVESEG - Segment IEN
- +6 IF $GET(FROMVER)=""!'$DATA(ASAPDEF)!($GET(TOVER)="")!($GET(ELMID)="")
- QUIT "-1^Invalid Input Parameters"
- +7 NEW STDIEN,CUSIEN,TOVERIEN,TOSEGIEN,ELMDEF,ELMIEN,ELMDATA
- +8 SET STDIEN=$ORDER(^PS(58.4,"B","STANDARD ASAP DEFINITION",0))
- +9 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
- +10 ; From ASAP Version must exist (Standard or Custom)
- +11 IF '$DATA(^PS(58.4,STDIEN,"VER","B",FROMVER))
- IF '$DATA(^PS(58.4,CUSIEN,"VER","B",FROMVER))
- QUIT "-1^Source ASAP Version does not exist."
- +12 ; To ASAP Version must exist (Custom) - If not, create it
- +13 SET TOVERIEN=$ORDER(^PS(58.4,CUSIEN,"VER","B",TOVER,9999),-1)
- +14 IF 'TOVERIEN
- SET TOVERIEN=$$SAVEVER(TOVER,ASAPDEF)
- IF TOVERIEN<0
- QUIT "-1^Invalid Custom ASAP Version"
- +15 SET SEGID=$$GETSEGID(ELMID)
- IF SEGID=""
- QUIT "-1^Invalid Segment ID "_SEGID_"."
- +16 ; Custom ASAP Segment must exist - If not, create it
- +17 SET TOSEGIEN=$ORDER(^PS(58.4,CUSIEN,"VER",TOVERIEN,"SEG","B",SEGID,9999),-1)
- +18 IF 'TOSEGIEN
- SET TOSEGIEN=$$SAVESEG(TOVER,SEGID,ASAPDEF(SEGID),ASAPDEF)
- IF 'TOSEGIEN
- QUIT "-1^Segment ID does not exist in the destin ASAP Version."
- +19 ; Segment ID already on file (cannot be copied again)
- +20 IF $ORDER(^PS(58.4,CUSIEN,"VER",TOVERIEN,"SEG",TOSEGIEN,"DAT","B",ELMID,9999),-1)
- QUIT "-1^Data Element already on file"
- +21 IF '$DATA(ASAPDEF(SEGID,ELMPOS))
- QUIT "-1^Data Element does not exist in the source ASAP Version."
- +22 KILL ELMDATA
- MERGE ELMDATA=ASAPDEF(SEGID,ELMPOS)
- +23 QUIT $$SAVEELM(TOVER,SEGID,"+1",.ELMDATA)
- +24 ;
- SAVEELM(ASAPVER,SEGID,ELMID,ELMDATA) ; Saves a Data Element
- +1 ;Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.)
- +2 ; (r) SEGID - Segment ID ("PHA", "DSP", etc.)
- +3 ; (r) ELMID - Data Element ID ("PHA01", "DSP05", etc.) or "+1" to add a new Data Element
- +4 ; (r) ELMDATA - Data Element Data
- +5 ;Output: SAVEELM - Data Element IEN
- +6 IF $GET(ASAPVER)=""!($GET(SEGID)="")!($GET(ELMID)="")!($GET(ELMDATA)="")
- QUIT "-1^Invalid Input Parameters"
- +7 NEW SAVEELM,CUSIEN,VERIEN,ELMIEN,ELMDEF,SEGIEN
- +8 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
- IF 'CUSIEN
- QUIT "-1^Invalid Custom ASAP Data Definition"
- +9 ; Custom ASAP Version must exist
- +10 SET VERIEN=$ORDER(^PS(58.4,CUSIEN,"VER","B",ASAPVER,9999),-1)
- IF 'VERIEN
- QUIT "-1^Invalid Custom ASAP Version"
- +11 ; Custom ASAP Segment must exist
- +12 SET SEGIEN=$ORDER(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG","B",SEGID,9999),-1)
- IF 'SEGIEN
- QUIT "-1^Segment ID does not exist in the destin ASAP Version."
- +13 SET ELMIEN=ELMID
- +14 IF ELMIEN'="+1"
- SET ELMIEN=$ORDER(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG",SEGIEN,"DAT","B",ELMID,9999),-1)
- IF 'ELMIEN
- QUIT "-1^Invalid Custom ASAP Data Element"
- +15 ; Saving Data Element
- +16 ;Element ID
- SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.01)=$PIECE(ELMDATA,"^",1)
- +17 ;Element Name
- SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.02)=$PIECE(ELMDATA,"^",2)
- +18 ;Data Format
- SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.03)=$PIECE(ELMDATA,"^",3)
- +19 ;Maximum Length
- SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.04)=$PIECE(ELMDATA,"^",4)
- +20 ;Position
- SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.05)=$PIECE(ELMDATA,"^",5)
- +21 ;Requirement
- SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.06)=$PIECE(ELMDATA,"^",6)
- +22 ;Description
- SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.07)="ELMDATA(""DES"")"
- +23 ;Value
- SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.08)="ELMDATA(""VAL"")"
- +24 DO UPDATE^DIE("","ELMDEF","SAVEELM","")
- +25 IF ELMIEN="+1"
- SET ELMIEN=+$GET(SAVEELM(1))
- +26 QUIT ELMIEN
- +27 ;
- CUSSEG(ASAPVER,SEGID) ; Customized Segment?
- +1 ;Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.)
- +2 ; (r) SEGID - Segment ID
- +3 ;Output: Customized Segment? 1: YES / 0: NO
- +4 IF $GET(ASAPVER)=""!($GET(SEGID)="")
- QUIT 0
- +5 NEW STDASAP,CUSASAP
- +6 ; Standard ASAP Definition
- DO LOADASAP^PSOSPMU0(ASAPVER,"S",.STDASAP)
- +7 ; Custom ASAP Definition
- DO LOADASAP^PSOSPMU0(ASAPVER,"C",.CUSASAP)
- +8 IF $GET(CUSASAP(SEGID))=""
- QUIT 0
- +9 IF $GET(STDASAP(SEGID))=$GET(CUSASAP(SEGID))
- QUIT 0
- +10 QUIT 1
- +11 ;
- DELCUS(ASAPVER,SEGID,ELMID) ; Delete/Reset a Customization
- +1 ;Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.)
- +2 ; (o) SEGID - Segment ID ("PHA", "DSP", etc.)
- +3 ; (o) ELMID - Data Element ID ("PHA01", "DSP02", etc.)
- +4 IF $GET(ASAPVER)=""
- QUIT
- +5 NEW STDASAP,CUSASAP,CUSIEN,VERIEN,SEGIEN,ELMIEN,DIK,DA
- +6 ; Standard ASAP Definition
- DO LOADASAP^PSOSPMU0(ASAPVER,"S",.STDASAP)
- +7 ; Custom ASAP Definition
- DO LOADASAP^PSOSPMU0(ASAPVER,"C",.CUSASAP)
- +8 ;
- +9 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",9999),-1)
- +10 SET VERIEN=$ORDER(^PS(58.4,CUSIEN,"VER","B",ASAPVER,9999),-1)
- IF 'VERIEN
- QUIT
- +11 IF $GET(SEGID)'=""
- Begin DoDot:1
- +12 SET SEGIEN=$ORDER(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG","B",SEGID,9999),-1)
- End DoDot:1
- +13 IF $GET(ELMID)'=""
- Begin DoDot:1
- +14 SET SEGIEN=$ORDER(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG","B",$$GETSEGID(ELMID),9999),-1)
- IF 'SEGIEN
- QUIT
- +15 SET ELMIEN=$ORDER(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG",SEGIEN,"DAT","B",ELMID,9999),-1)
- End DoDot:1
- +16 ;
- +17 IF $GET(SEGID)'=""
- IF '$GET(SEGIEN)
- QUIT
- +18 IF $GET(ELMID)'=""
- IF '$GET(ELMIEN)
- QUIT
- +19 ;
- +20 ; Deleting/Resetting a Custom Data Element
- +21 IF $GET(ELMID)'=""
- Begin DoDot:1
- +22 SET DIK="^PS(58.4,"_CUSIEN_",""VER"","_VERIEN_",""SEG"","_SEGIEN_",""DAT"","
- +23 SET DA(3)=CUSIEN
- SET DA(2)=VERIEN
- SET DA(1)=SEGIEN
- SET DA=ELMIEN
- DO ^DIK
- End DoDot:1
- QUIT
- +24 ;
- +25 ; Deleting/Resetting an Entire Custom Segment
- +26 IF $GET(SEGID)'=""
- Begin DoDot:1
- +27 SET DIK="^PS(58.4,"_CUSIEN_",""VER"","_VERIEN_",""SEG"","
- +28 SET DA(2)=CUSIEN
- SET DA(1)=VERIEN
- SET DA=SEGIEN
- DO ^DIK
- End DoDot:1
- QUIT
- +29 ;
- +30 ; Deleting/Resetting an Entire Custom ASAP Version
- +31 SET DIK="^PS(58.4,"_CUSIEN_",""VER"","
- +32 SET DA(1)=CUSIEN
- SET DA=VERIEN
- DO ^DIK
- +33 QUIT
- +34 ;
- GETSEGID(ELMID) ; Get the Segment ID from the Element ID
- +1 ;Input: (r) ELMID - Data Element ID ("PHA01", "DSP02", etc.)
- +2 NEW GETSEGID,I
- +3 SET GETSEGID=$GET(ELMID)
- FOR I=$LENGTH(ELMID):-1:1
- if ($EXTRACT(ELMID,I)'?1N)
- QUIT
- SET $EXTRACT(GETSEGID,I)=""
- +4 QUIT GETSEGID
- +5 ;
- VALID(ASAPVER,MEXPR) ; Validate the Mumps Expression for the ASAP Version
- +1 ;Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.) (Required for checking the delimiters)
- +2 ; (r) MEXPR - M SET Expression Argument to be validated
- +3 IF $GET(ASAPVER)=""!($GET(MEXPR)="")
- QUIT "0^Invalid Input Parameters"
- +4 NEW VALID,VERDATA,ELMDELIM,SEGDELIM,INQUOTES,CHAR,X,I
- +5 SET MEXPR=$$UP^XLFSTR(MEXPR)
- +6 IF $GET(MEXPR)=""
- QUIT "0^M SET Expression cannot be empty. Use """" for blank/null values."
- +7 IF $FIND(MEXPR," D ^")!$FIND(MEXPR," DO ^")!$FIND(MEXPR,"G ^")!$FIND(MEXPR,"GO ^")
- QUIT "0^M SET Expression cannot call out other routines."
- +8 IF $FIND(MEXPR,"K ^")!$FIND(MEXPR,"KILL ^")
- QUIT "0^M SET Expression cannot contain 'KILL' command."
- +9 IF $FIND(MEXPR," S ^")!$FIND(MEXPR," SET ^")
- QUIT "0^M SET Expression cannot contain 'SET' command."
- +10 IF $FIND(MEXPR," L +")!$FIND(MEXPR," L ^")!$FIND(MEXPR," LOCK ")
- QUIT "0^M SET Expression cannot contain 'LOCK' command."
- +11 IF $FIND(MEXPR,"$C(")
- QUIT "0^M SET Expression cannot contain special characters ($C)."
- +12 SET VALID=1
- SET VERDATA=$$VERDATA^PSOSPMU0(ASAPVER,"B")
- +13 SET ELMDELIM=$PIECE(VERDATA,"^",2)
- SET SEGDELIM=$PIECE(VERDATA,"^",3)
- +14 SET INQUOTES=0
- +15 FOR I=1:1:$LENGTH(MEXPR)
- Begin DoDot:1
- +16 SET CHAR=$EXTRACT(MEXPR,I)
- +17 IF ($ASCII(CHAR)<32)!($ASCII(CHAR)>176)
- SET VALID="0^M SET Expression cannot contain special characters."
- QUIT
- +18 IF CHAR=""""
- SET INQUOTES=((INQUOTES+1)#2)
- +19 IF INQUOTES
- Begin DoDot:2
- +20 IF CHAR=ELMDELIM
- SET VALID="0^M SET Expression Cannot contain the character '"_CHAR_"' (Element Delimiter)."
- QUIT
- +21 IF CHAR=SEGDELIM
- SET VALID="0^M SET Expression Cannot contain the character '"_CHAR_"' (Segment Terminator)."
- QUIT
- End DoDot:2
- +22 IF '$TEST
- Begin DoDot:2
- +23 IF CHAR=" "
- SET VALID="0^No Blank Space characters allowed outside quotes."
- QUIT
- End DoDot:2
- End DoDot:1
- IF VALID<0
- QUIT
- +24 ; The concatenated 'X' below is for security purposes
- +25 SET X="W "_MEXPR_"_""X"""
- DO ^DIM
- IF '$DATA(X)
- QUIT "0^M SET Expression syntax is invalid."
- +26 QUIT VALID
- +27 ;
- CHKVAR(LEVEL,MEXPR) ; Checks the variables in the M SET Expression
- +1 ; Input: (r) LEVEL - Level of the Segment where the Data Element is located
- +2 ; (r) MEXPR - Mumps SET Expression value to be verified
- +3 ;Output: $$CHKVAR - 1: No issues / 0: Invalid Variable use
- +4 IF '$GET(LEVEL)!$GET(MEXPR)=""
- QUIT 1
- +5 NEW CHKVAR,LEVNAM,VAR,OKLST
- +6 SET CHKVAR=""
- +7 IF LEVEL=4
- QUIT 1
- +8 IF LEVEL=1!(LEVEL=6)
- SET OKLST="STATEIEN,"
- +9 IF LEVEL=2!(LEVEL=5)
- SET OKLST="STATEIEN,SITEIEN,"
- +10 IF LEVEL=3
- SET OKLST="STATEIEN,SITEIEN,PATIEN"
- +11 FOR VAR="STATEIEN","SITEIEN","PATIEN","RXIEN","DRUGIEN","FILLNUM","FILLIEN","RPHIEN","PREIEN","RTSREC"
- Begin DoDot:1
- +12 IF MEXPR[VAR
- IF OKLST'[VAR
- SET CHKVAR=CHKVAR_$SELECT(CHKVAR'="":",",1:"")_VAR
- End DoDot:1
- +13 IF CHKVAR'=""
- Begin DoDot:1
- +14 SET LEVNAM=$PIECE("MAIN HEADER^PHARMACY HEADER^PATIENT DETAIL^PRESCRIPTION DETAIL^PHARMACY TRAILER^MAIN TRAILER","^",LEVEL)
- +15 WRITE !,"The variable",$SELECT(CHKVAR[",":"s",1:"")," ",CHKVAR," ",$SELECT(CHKVAR[",":"are",1:"is")," not available at the ",LEVNAM," level.",$CHAR(7),!
- End DoDot:1
- QUIT 0
- +16 QUIT 1
- +17 ;
- CHKCODE(LEVEL,MEXPR,ERROR) ; Checks the data retrieval code for the Data Element
- +1 ; Input: (r) LEVEL - Level of the Segment where the Data Element is located
- +2 ; (r) MEXPR - Mumps SET Expression value to be verified
- +3 ;Output: ERROR - Indicate whether an ERROR occurred or not (1: Yes, 0: No)
- +4 IF '$GET(LEVEL)!$GET(MEXPR)=""
- QUIT
- +5 NEW QUIT,STATEIEN,SITEIEN,LASTRD,PATIEN,DFN,RXIEN,DRUGIEN,FILLIEN,FILLNUM,PREIEN,RPHIEN,RTSREC,CODE,X
- +6 NEW RECTYPE
- +7 SET ERROR=0
- +8 IF '$GET(LEVEL)!$GET(MEXPR)=""
- QUIT
- +9 SET (QUIT,SITEIEN,PATIEN,DFN,RXIEN,DRUGIEN,FILLIEN,PREIEN,RPHIEN,FILLNUM,RTSREC)=0
- +10 Begin DoDot:1
- +11 SET LASTRD=$ORDER(^PSRX("AL",9999999),-1)
- IF 'LASTRD
- SET QUIT=1
- QUIT
- +12 SET RXIEN=$ORDER(^PSRX("AL",LASTRD,0))
- IF '$DATA(^PSRX(RXIEN,0))
- SET QUIT=1
- QUIT
- +13 SET SITEIEN=$$RXSITE^PSOBPSUT(RXIEN,0)
- +14 SET STATEIEN=$$GET1^DIQ(59,SITEIEN,.08,"I")
- +15 IF LEVEL=1!(LEVEL=6)
- KILL SITEIEN,PATIEN,DFN,RXIEN,DRUGIEN,FILLIEN,FILLNUM,PREIEN,RPHIEN,RTSREC
- QUIT
- +16 IF LEVEL=2!(LEVEL=5)
- KILL PATIEN,DFN,RXIEN,DRUGIEN,FILLIEN,FILLNUM,PREIEN,RPHIEN,RTSREC
- QUIT
- +17 SET (PATIEN,DFN)=$$GET1^DIQ(52,RXIEN,2,"I")
- DO SETNAME^PSOSPMUT(PATIEN)
- +18 IF LEVEL=3
- KILL RXIEN,DRUGIEN,FILLIEN,FILLNUM,PREIEN,RPHIEN,RTSREC
- QUIT
- +19 SET DRUGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
- +20 SET FILLIEN=0
- SET FILLNUM=0
- SET RECTYPE="N"
- +21 SET PREIEN=$$RXPRV^PSOBPSUT(RXIEN,0)
- +22 SET RPHIEN=$$RXRPH^PSOBPSUT(RXIEN,0)
- End DoDot:1
- IF QUIT
- QUIT
- +23 SET CODE="S X="_MEXPR
- +24 NEW $ETRAP,$ESTACK
- SET $ETRAP="D ERROR^PSOSPMU3"
- +25 XECUTE CODE
- +26 QUIT
- +27 ;
- ERROR ; Error Trap to test ASAP Data Retrieval
- +1 NEW ZE,DIR,DRUT,DTOUT,X,Y
- +2 SET ZE=$$EC^%ZOSV
- +3 IF ZE["<UNDEFINED>"
- Begin DoDot:1
- +4 WRITE !,"The code will likely throw an <UNDEFINED> error for the "
- +5 WRITE $SELECT(ZE["*":"variable '",1:"global ^"),$SELECT(ZE["*":$PIECE(ZE,"*",2)_"'",1:$PIECE(ZE,"^",3)),".",$CHAR(7)
- +6 SET DIR(0)="Y"
- SET DIR("B")="NO"
- SET DIR("A")="Continue Anyway"
- DO ^DIR
- IF '$GET(Y)
- SET ERROR=1
- End DoDot:1
- +7 IF '$TEST
- WRITE !,"The code will throw a <",$PIECE($PIECE(ZE,"<",2),">"),"> error for this expression.",$CHAR(7)
- SET ERROR=1
- +8 ; Continue on
- +9 WRITE !
- GOTO UNWIND^%ZTER