PSOSPMU3 ;BIRM/MFR - State Prescription Monitoring Program Utility #3 - Customization ;10/07/15
;;7.0;OUTPATIENT PHARMACY;**451,625,772**;DEC 1997;Build 105
;
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,ASAPSHDR,ASAPCHDR,ASAPCIEN
S CUSIEN=$O(^PS(58.4,"B","STANDARD ASAP DEFINITION",0)) ; PSO*7*772-Store custom ASAP versions in standard node
; New ASAP Version already exists
I $D(^PS(58.4,CUSIEN,"VER","B",NEWVER)) Q
D LOADASAP^PSOSPMU0(FROMVER,"S",.ASAPDEF) ; First clone standard definitions - PSO*7*772
S $P(ASAPDEF,"^",6)=FROMVER ; Capture COPIED FROM ASAP VERSION
S NWVERIEN=$$SAVEVER(NEWVER,.ASAPDEF,1) I NWVERIEN'>0 Q
;
S SEGID="999"
F S SEGID=$O(ASAPDEF(SEGID)) Q:SEGID="" D
. S SEGIEN=$$COPYSEG(FROMVER,.ASAPDEF,NEWVER,SEGID,1) 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,1) ; Save custom ASAP version in standard node
; PSO*7*772 Begin
Q:$G(DEFTYPE)="S" ;; If DEFTYPE is "C" (custom) or "B" (both), move customizations PSO*7*772
;
S CUSIEN=$O(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0)) ; Reset CUSIEN to custom node
S ASAPSHDR=$G(ASAPDEF) ; Save ASAP Standard Header
K ASAPDEF ; Reset ASAP array
; New ASAP Version already exists
I $D(^PS(58.4,CUSIEN,"VER","B",NEWVER)) Q
D LOADASAP^PSOSPMU0(FROMVER,"C",.ASAPDEF)
S ASAPCIEN=$O(^PS(58.4,CUSIEN,"VER","B",FROMVER,0))
Q:'$G(ASAPCIEN)
S ASAPCHDR=$G(^PS(58.4,CUSIEN,"VER",ASAPCIEN,0))
S ASAPDEF=$S($L(ASAPCHDR):ASAPCHDR,1:ASAPSHDR) ; Use custom header values if they exist
S $P(ASAPDEF,"^",6)=FROMVER ; Set COPIED FROM ASAP VERSION
S NWVERIEN=$$SAVEVER(NEWVER,.ASAPDEF,0) I NWVERIEN'>0 Q ; Save custom ASAP Version in custom node
;
S SEGID="999"
F S SEGID=$O(ASAPDEF(SEGID)) Q:SEGID="" D
. S SEGIEN=$$COPYSEG(FROMVER,.ASAPDEF,NEWVER,SEGID,0) 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,0) ; Save individual customizations in custom node PSO*7*772 End
Q
;
SAVEVER(ASAPVER,VERDATA,CLONE) ; Save an ASAP Version
;Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.)
; (r) VERDATA - ASAP Version Data
; (o) CLONE - Standard Clone ASAP Version PSO*7*772
;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"
I $G(CLONE) S CUSIEN=$O(^PS(58.4,"B","STANDARD ASAP DEFINITION",0)) ;PSO*7*772
; 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
S VERDEF(58.4001,VERIEN_","_CUSIEN_",",.06)=$P(VERDATA,"^",6)
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,CLONE) ; 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.)
; (o) CLONE - Standard Clone ASAP Version Flag PSO*7*772
;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))
I $G(CLONE) S CUSIEN=$O(^PS(58.4,"B","STANDARD ASAP DEFINITION",0)) ;PSO*7*772
; 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,$G(CLONE))
;
SAVESEG(ASAPVER,SEGID,SEGDATA,VERDATA,CLONE) ; 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)
; (o) CLONE - Standard Clone ASAP Version Flag PSO*7*772
;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"
I $G(CLONE) S CUSIEN=$O(^PS(58.4,"B","STANDARD ASAP DEFINITION",0)) ;PSO*7*772
; 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,CLONE) ; 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.)
; (o) CLONE - Standard Clone ASAP Version Flag PSO*7*772
;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))
I $G(CLONE) S CUSIEN=$O(^PS(58.4,"B","STANDARD ASAP DEFINITION",0)) ;PSO*7*772
; 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<0 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,$G(CLONE))
;
SAVEELM(ASAPVER,SEGID,ELMID,ELMDATA,CLONE) ; 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
; (o) CLONE - Standard Clone ASAP Version
;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,ELMERR
S CUSIEN=$O(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0)) I 'CUSIEN Q "-1^Invalid Custom ASAP Data Definition"
I $G(CLONE) S CUSIEN=$O(^PS(58.4,"B","STANDARD ASAP DEFINITION",0)) ;PSO*7*772
; 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","ELMERR")
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,DELSTDV) ; 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.)
; (o) DELSTDV - Delete Standard Clone ASAP Version?
I $G(ASAPVER)="" Q
N STDASAP,CUSASAP,CUSIEN,VERIEN,SEGIEN,ELMIEN,DIK,DA,DELVERIEN,STDIEN
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 '$P($G(DELSTDV),"^"),'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
I $G(DELSTDV) S STDIEN=$P(DELSTDV,"^",2) I STDIEN D Q
. S DIK="^PS(58.4,"_CUSIEN_",""VER"",",DA(1)=CUSIEN,DA=VERIEN D ^DIK ; Remove standard clone ASAP customizations PSO*7*772
. S DIK="^PS(58.4,"_STDIEN_",""VER"",",DA(1)=STDIEN,DA=+DELSTDV D ^DIK ; Remove standard clone ASAP definition PSO*7*772
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
;
DELSTDV(ASAPVER,SEGID,ELMID) ; Delete 'Standard' Custom ASAP Version - PSO*7*772
;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
K DELVIEN,STDIEN
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)
I ($G(ELMID)'="")!($G(SEGID)'="") Q "" ; Not performing a Version Deletion
I '$L($P($G(STDASAP),"^",6)) Q "" ; Version is not a 'Standard Clone'
S STDIEN=$O(^PS(58.4,"B","STANDARD ASAP DEFINITION",9999),-1)
S DELVIEN=$O(^PS(58.4,STDIEN,"VER","B",ASAPVER,9999),-1)
I '($G(STDIEN)&$G(DELVIEN)) Q ""
Q $G(DELVIEN)_"^"_$G(STDIEN)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSPMU3 19431 printed Aug 26, 2025@22:51:20 Page 2
PSOSPMU3 ;BIRM/MFR - State Prescription Monitoring Program Utility #3 - Customization ;10/07/15
+1 ;;7.0;OUTPATIENT PHARMACY;**451,625,772**;DEC 1997;Build 105
+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,ASAPSHDR,ASAPCHDR,ASAPCIEN
+6 ; PSO*7*772-Store custom ASAP versions in standard node
SET CUSIEN=$ORDER(^PS(58.4,"B","STANDARD ASAP DEFINITION",0))
+7 ; New ASAP Version already exists
+8 IF $DATA(^PS(58.4,CUSIEN,"VER","B",NEWVER))
QUIT
+9 ; First clone standard definitions - PSO*7*772
DO LOADASAP^PSOSPMU0(FROMVER,"S",.ASAPDEF)
+10 ; Capture COPIED FROM ASAP VERSION
SET $PIECE(ASAPDEF,"^",6)=FROMVER
+11 SET NWVERIEN=$$SAVEVER(NEWVER,.ASAPDEF,1)
IF NWVERIEN'>0
QUIT
+12 ;
+13 SET SEGID="999"
+14 FOR
SET SEGID=$ORDER(ASAPDEF(SEGID))
if SEGID=""
QUIT
Begin DoDot:1
+15 SET SEGIEN=$$COPYSEG(FROMVER,.ASAPDEF,NEWVER,SEGID,1)
IF SEGIEN'>0
QUIT
+16 SET ELMPOS=""
+17 FOR
SET ELMPOS=$ORDER(ASAPDEF(SEGID,ELMPOS))
if ELMPOS=""
QUIT
Begin DoDot:2
+18 SET ELMID=$PIECE(ASAPDEF(SEGID,ELMPOS),"^")
+19 ; Save custom ASAP version in standard node
SET ELMIEN=$$COPYELM(FROMVER,.ASAPDEF,NEWVER,ELMID,1)
End DoDot:2
End DoDot:1
+20 ; PSO*7*772 Begin
+21 ;; If DEFTYPE is "C" (custom) or "B" (both), move customizations PSO*7*772
if $GET(DEFTYPE)="S"
QUIT
+22 ;
+23 ; Reset CUSIEN to custom node
SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
+24 ; Save ASAP Standard Header
SET ASAPSHDR=$GET(ASAPDEF)
+25 ; Reset ASAP array
KILL ASAPDEF
+26 ; New ASAP Version already exists
+27 IF $DATA(^PS(58.4,CUSIEN,"VER","B",NEWVER))
QUIT
+28 DO LOADASAP^PSOSPMU0(FROMVER,"C",.ASAPDEF)
+29 SET ASAPCIEN=$ORDER(^PS(58.4,CUSIEN,"VER","B",FROMVER,0))
+30 if '$GET(ASAPCIEN)
QUIT
+31 SET ASAPCHDR=$GET(^PS(58.4,CUSIEN,"VER",ASAPCIEN,0))
+32 ; Use custom header values if they exist
SET ASAPDEF=$SELECT($LENGTH(ASAPCHDR):ASAPCHDR,1:ASAPSHDR)
+33 ; Set COPIED FROM ASAP VERSION
SET $PIECE(ASAPDEF,"^",6)=FROMVER
+34 ; Save custom ASAP Version in custom node
SET NWVERIEN=$$SAVEVER(NEWVER,.ASAPDEF,0)
IF NWVERIEN'>0
QUIT
+35 ;
+36 SET SEGID="999"
+37 FOR
SET SEGID=$ORDER(ASAPDEF(SEGID))
if SEGID=""
QUIT
Begin DoDot:1
+38 SET SEGIEN=$$COPYSEG(FROMVER,.ASAPDEF,NEWVER,SEGID,0)
IF SEGIEN'>0
QUIT
+39 SET ELMPOS=""
+40 FOR
SET ELMPOS=$ORDER(ASAPDEF(SEGID,ELMPOS))
if ELMPOS=""
QUIT
Begin DoDot:2
+41 SET ELMID=$PIECE(ASAPDEF(SEGID,ELMPOS),"^")
+42 ; Save individual customizations in custom node PSO*7*772 End
SET ELMIEN=$$COPYELM(FROMVER,.ASAPDEF,NEWVER,ELMID,0)
End DoDot:2
End DoDot:1
+43 QUIT
+44 ;
SAVEVER(ASAPVER,VERDATA,CLONE) ; Save an ASAP Version
+1 ;Input: (r) ASAPVER - ASAP Version ("3.0", "4.0", etc.)
+2 ; (r) VERDATA - ASAP Version Data
+3 ; (o) CLONE - Standard Clone ASAP Version PSO*7*772
+4 ;Output: SAVVER - ASAP Version IEN
+5 IF $GET(ASAPVER)=""!($GET(VERDATA)="")
QUIT "-1^Invalid Input Parameters"
+6 NEW SAVEVER,CUSIEN,VERIEN,VERDEF
+7 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
IF 'CUSIEN
QUIT "-1^Invalid Custom ASAP Data Definition"
+8 ;PSO*7*772
IF $GET(CLONE)
SET CUSIEN=$ORDER(^PS(58.4,"B","STANDARD ASAP DEFINITION",0))
+9 ; If Custom ASAP Version entry does not exist, create it
+10 SET VERIEN=$ORDER(^PS(58.4,CUSIEN,"VER","B",ASAPVER,0))
IF 'VERIEN
SET VERIEN="+1"
+11 ;
+12 SET VERDEF(58.4001,VERIEN_","_CUSIEN_",",.01)=ASAPVER
+13 SET VERDEF(58.4001,VERIEN_","_CUSIEN_",",.02)=$PIECE(VERDATA,"^",2)
+14 SET VERDEF(58.4001,VERIEN_","_CUSIEN_",",.03)=$PIECE(VERDATA,"^",3)
+15 SET VERDEF(58.4001,VERIEN_","_CUSIEN_",",.04)=$PIECE(VERDATA,"^",4)
+16 ;Denotes Zero Report Version
SET VERDEF(58.4001,VERIEN_","_CUSIEN_",",.05)=$PIECE(VERDATA,"^",5)
+17 SET VERDEF(58.4001,VERIEN_","_CUSIEN_",",.06)=$PIECE(VERDATA,"^",6)
+18 DO UPDATE^DIE("","VERDEF","SAVEVER","")
+19 if VERIEN="+1"
SET VERIEN=+$GET(SAVEVER(1))
+20 ; Necessary to force the '@' as a delimiter/terminator
+21 IF $PIECE(VERDATA,"^",2)="@"
IF VERIEN
SET $PIECE(^PS(58.4,CUSIEN,"VER",VERIEN,0),"^",2)="@"
+22 IF $PIECE(VERDATA,"^",3)="@"
IF VERIEN
SET $PIECE(^PS(58.4,CUSIEN,"VER",VERIEN,0),"^",3)="@"
+23 QUIT VERIEN
+24 ;
COPYSEG(FROMVER,ASAPDEF,TOVER,SEGID,CLONE) ; 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 ; (o) CLONE - Standard Clone ASAP Version Flag PSO*7*772
+6 ;Output: SAVESEG - New Segment IEN
+7 IF $GET(FROMVER)=""!($GET(TOVER)="")!($GET(SEGID)="")
QUIT "-1^Invalid Input Parameters"
+8 NEW STDIEN,CUSIEN,TOVERIEN,SEGDEF,SEGIEN
+9 SET STDIEN=$ORDER(^PS(58.4,"B","STANDARD ASAP DEFINITION",0))
+10 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
+11 ;PSO*7*772
IF $GET(CLONE)
SET CUSIEN=$ORDER(^PS(58.4,"B","STANDARD ASAP DEFINITION",0))
+12 ; From ASAP Version must exist (Standard or Custom)
+13 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."
+14 ; To ASAP Version must exist (Custom) - If not, try to create it
+15 SET TOVERIEN=$ORDER(^PS(58.4,CUSIEN,"VER","B",TOVER,9999),-1)
+16 IF 'TOVERIEN
SET TOVERIEN=$$SAVEVER(TOVER,ASAPDEF)
IF TOVERIEN<0
QUIT TOVERIEN
+17 ; Segment ID already on file (cannot be copied again)
+18 IF $ORDER(^PS(58.4,CUSIEN,"VER",TOVERIEN,"SEG","B",SEGID,0))
QUIT "-1^Segment ID already on file"
+19 IF '$DATA(ASAPDEF(SEGID))
QUIT "-1^Missing new segment data"
+20 QUIT $$SAVESEG(TOVER,"+1",ASAPDEF(SEGID),ASAPDEF,$GET(CLONE))
+21 ;
SAVESEG(ASAPVER,SEGID,SEGDATA,VERDATA,CLONE) ; 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 ; (o) CLONE - Standard Clone ASAP Version Flag PSO*7*772
+6 ;Output: SAVESEG - Segment IEN
+7 IF $GET(ASAPVER)=""!($GET(SEGID)="")!($GET(SEGDATA)="")
QUIT "-1^Invalid Input Parameters"
+8 NEW SAVESEG,CUSIEN,VERIEN,SEGIEN,SEGDEF
+9 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
IF 'CUSIEN
QUIT "-1^Invalid Custom ASAP Data Definition"
+10 ;PSO*7*772
IF $GET(CLONE)
SET CUSIEN=$ORDER(^PS(58.4,"B","STANDARD ASAP DEFINITION",0))
+11 ; Custom ASAP Version must exist - If not, create it
+12 SET VERIEN=$ORDER(^PS(58.4,CUSIEN,"VER","B",ASAPVER,9999),-1)
+13 IF 'VERIEN
SET VERIEN=$$SAVEVER(ASAPVER,VERDATA)
IF VERIEN<0
QUIT "-1^Invalid Custom ASAP Version"
+14 SET SEGIEN=SEGID
+15 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"
+16 ;Segment ID
SET SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.01)=$PIECE(SEGDATA,"^",1)
+17 ;Segment Name
SET SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.02)=$PIECE(SEGDATA,"^",2)
+18 ;Parent Segment
SET SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.03)=$PIECE(SEGDATA,"^",3)
+19 ;Requirement
SET SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.04)=$PIECE(SEGDATA,"^",4)
+20 ;Position
SET SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.05)=$PIECE(SEGDATA,"^",5)
+21 ;Level
SET SEGDEF(58.40011,SEGIEN_","_VERIEN_","_CUSIEN_",",.06)=$PIECE(SEGDATA,"^",6)
+22 DO UPDATE^DIE("","SEGDEF","SAVESEG","")
+23 IF SEGIEN="+1"
SET SEGIEN=+$GET(SAVESEG(1))
+24 QUIT SEGIEN
+25 ;
COPYELM(FROMVER,ASAPDEF,TOVER,ELMID,CLONE) ; 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 ; (o) CLONE - Standard Clone ASAP Version Flag PSO*7*772
+6 ;Output: SAVESEG - Segment IEN
+7 IF $GET(FROMVER)=""!'$DATA(ASAPDEF)!($GET(TOVER)="")!($GET(ELMID)="")
QUIT "-1^Invalid Input Parameters"
+8 NEW STDIEN,CUSIEN,TOVERIEN,TOSEGIEN,ELMDEF,ELMIEN,ELMDATA
+9 SET STDIEN=$ORDER(^PS(58.4,"B","STANDARD ASAP DEFINITION",0))
+10 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
+11 ;PSO*7*772
IF $GET(CLONE)
SET CUSIEN=$ORDER(^PS(58.4,"B","STANDARD ASAP DEFINITION",0))
+12 ; From ASAP Version must exist (Standard or Custom)
+13 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."
+14 ; To ASAP Version must exist (Custom) - If not, create it
+15 SET TOVERIEN=$ORDER(^PS(58.4,CUSIEN,"VER","B",TOVER,9999),-1)
+16 IF 'TOVERIEN
SET TOVERIEN=$$SAVEVER(TOVER,ASAPDEF)
IF TOVERIEN<0
QUIT "-1^Invalid Custom ASAP Version"
+17 SET SEGID=$$GETSEGID(ELMID)
IF SEGID=""
QUIT "-1^Invalid Segment ID "_SEGID_"."
+18 ; Custom ASAP Segment must exist - If not, create it
+19 SET TOSEGIEN=$ORDER(^PS(58.4,CUSIEN,"VER",TOVERIEN,"SEG","B",SEGID,9999),-1)
+20 IF 'TOSEGIEN
SET TOSEGIEN=$$SAVESEG(TOVER,SEGID,ASAPDEF(SEGID),ASAPDEF)
IF TOSEGIEN<0
QUIT "-1^Segment ID does not exist in the destin ASAP Version."
+21 ; Segment ID already on file (cannot be copied again)
+22 IF $ORDER(^PS(58.4,CUSIEN,"VER",TOVERIEN,"SEG",TOSEGIEN,"DAT","B",ELMID,9999),-1)
QUIT "-1^Data Element already on file"
+23 IF '$DATA(ASAPDEF(SEGID,ELMPOS))
QUIT "-1^Data Element does not exist in the source ASAP Version."
+24 KILL ELMDATA
MERGE ELMDATA=ASAPDEF(SEGID,ELMPOS)
+25 QUIT $$SAVEELM(TOVER,SEGID,"+1",.ELMDATA,$GET(CLONE))
+26 ;
SAVEELM(ASAPVER,SEGID,ELMID,ELMDATA,CLONE) ; 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 ; (o) CLONE - Standard Clone ASAP Version
+6 ;Output: SAVEELM - Data Element IEN
+7 IF $GET(ASAPVER)=""!($GET(SEGID)="")!($GET(ELMID)="")!($GET(ELMDATA)="")
QUIT "-1^Invalid Input Parameters"
+8 NEW SAVEELM,CUSIEN,VERIEN,ELMIEN,ELMDEF,SEGIEN,ELMERR
+9 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",0))
IF 'CUSIEN
QUIT "-1^Invalid Custom ASAP Data Definition"
+10 ;PSO*7*772
IF $GET(CLONE)
SET CUSIEN=$ORDER(^PS(58.4,"B","STANDARD ASAP DEFINITION",0))
+11 ; Custom ASAP Version must exist
+12 SET VERIEN=$ORDER(^PS(58.4,CUSIEN,"VER","B",ASAPVER,9999),-1)
IF 'VERIEN
QUIT "-1^Invalid Custom ASAP Version"
+13 ; Custom ASAP Segment must exist
+14 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."
+15 SET ELMIEN=ELMID
+16 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"
+17 ; Saving Data Element
+18 ;Element ID
SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.01)=$PIECE(ELMDATA,"^",1)
+19 ;Element Name
SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.02)=$PIECE(ELMDATA,"^",2)
+20 ;Data Format
SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.03)=$PIECE(ELMDATA,"^",3)
+21 ;Maximum Length
SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.04)=$PIECE(ELMDATA,"^",4)
+22 ;Position
SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.05)=$PIECE(ELMDATA,"^",5)
+23 ;Requirement
SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.06)=$PIECE(ELMDATA,"^",6)
+24 ;Description
SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.07)="ELMDATA(""DES"")"
+25 ;Value
SET ELMDEF(58.400111,ELMIEN_","_SEGIEN_","_VERIEN_","_CUSIEN_",",.08)="ELMDATA(""VAL"")"
+26 DO UPDATE^DIE("","ELMDEF","SAVEELM","ELMERR")
+27 IF ELMIEN="+1"
SET ELMIEN=+$GET(SAVEELM(1))
+28 QUIT ELMIEN
+29 ;
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,DELSTDV) ; 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 ; (o) DELSTDV - Delete Standard Clone ASAP Version?
+5 IF $GET(ASAPVER)=""
QUIT
+6 NEW STDASAP,CUSASAP,CUSIEN,VERIEN,SEGIEN,ELMIEN,DIK,DA,DELVERIEN,STDIEN
+7 ; Standard ASAP Definition
DO LOADASAP^PSOSPMU0(ASAPVER,"S",.STDASAP)
+8 ; Custom ASAP Definition
DO LOADASAP^PSOSPMU0(ASAPVER,"C",.CUSASAP)
+9 ;
+10 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",9999),-1)
+11 SET VERIEN=$ORDER(^PS(58.4,CUSIEN,"VER","B",ASAPVER,9999),-1)
+12 IF '$PIECE($GET(DELSTDV),"^")
IF 'VERIEN
QUIT
+13 IF $GET(SEGID)'=""
Begin DoDot:1
+14 SET SEGIEN=$ORDER(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG","B",SEGID,9999),-1)
End DoDot:1
+15 IF $GET(ELMID)'=""
Begin DoDot:1
+16 SET SEGIEN=$ORDER(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG","B",$$GETSEGID(ELMID),9999),-1)
IF 'SEGIEN
QUIT
+17 SET ELMIEN=$ORDER(^PS(58.4,CUSIEN,"VER",VERIEN,"SEG",SEGIEN,"DAT","B",ELMID,9999),-1)
End DoDot:1
+18 ;
+19 IF $GET(SEGID)'=""
IF '$GET(SEGIEN)
QUIT
+20 IF $GET(ELMID)'=""
IF '$GET(ELMIEN)
QUIT
+21 ;
+22 ; Deleting/Resetting a Custom Data Element
+23 IF $GET(ELMID)'=""
Begin DoDot:1
+24 SET DIK="^PS(58.4,"_CUSIEN_",""VER"","_VERIEN_",""SEG"","_SEGIEN_",""DAT"","
+25 SET DA(3)=CUSIEN
SET DA(2)=VERIEN
SET DA(1)=SEGIEN
SET DA=ELMIEN
DO ^DIK
End DoDot:1
QUIT
+26 ;
+27 ; Deleting/Resetting an Entire Custom Segment
+28 IF $GET(SEGID)'=""
Begin DoDot:1
+29 SET DIK="^PS(58.4,"_CUSIEN_",""VER"","_VERIEN_",""SEG"","
+30 SET DA(2)=CUSIEN
SET DA(1)=VERIEN
SET DA=SEGIEN
DO ^DIK
End DoDot:1
QUIT
+31 ;
+32 ; Deleting/Resetting an Entire Custom ASAP Version
+33 IF $GET(DELSTDV)
SET STDIEN=$PIECE(DELSTDV,"^",2)
IF STDIEN
Begin DoDot:1
+34 ; Remove standard clone ASAP customizations PSO*7*772
SET DIK="^PS(58.4,"_CUSIEN_",""VER"","
SET DA(1)=CUSIEN
SET DA=VERIEN
DO ^DIK
+35 ; Remove standard clone ASAP definition PSO*7*772
SET DIK="^PS(58.4,"_STDIEN_",""VER"","
SET DA(1)=STDIEN
SET DA=+DELSTDV
DO ^DIK
End DoDot:1
QUIT
+36 SET DIK="^PS(58.4,"_CUSIEN_",""VER"","
+37 SET DA(1)=CUSIEN
SET DA=VERIEN
DO ^DIK
+38 QUIT
+39 ;
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
+10 ;
DELSTDV(ASAPVER,SEGID,ELMID) ; Delete 'Standard' Custom ASAP Version - PSO*7*772
+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 KILL DELVIEN,STDIEN
+6 NEW STDASAP,CUSASAP,CUSIEN,VERIEN,SEGIEN,ELMIEN,DIK,DA
+7 ; Standard ASAP Definition
DO LOADASAP^PSOSPMU0(ASAPVER,"S",.STDASAP)
+8 ; Custom ASAP Definition
DO LOADASAP^PSOSPMU0(ASAPVER,"C",.CUSASAP)
+9 ;
+10 SET CUSIEN=$ORDER(^PS(58.4,"B","CUSTOM ASAP DEFINITION",9999),-1)
+11 ; Not performing a Version Deletion
IF ($GET(ELMID)'="")!($GET(SEGID)'="")
QUIT ""
+12 ; Version is not a 'Standard Clone'
IF '$LENGTH($PIECE($GET(STDASAP),"^",6))
QUIT ""
+13 SET STDIEN=$ORDER(^PS(58.4,"B","STANDARD ASAP DEFINITION",9999),-1)
+14 SET DELVIEN=$ORDER(^PS(58.4,STDIEN,"VER","B",ASAPVER,9999),-1)
+15 IF '($GET(STDIEN)&$GET(DELVIEN))
QUIT ""
+16 QUIT $GET(DELVIEN)_"^"_$GET(STDIEN)
