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 Apr 09, 2024@21:26:07 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
