Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOSPMU3

PSOSPMU3.m

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