PSOERXU2 ;ALB/BWF - eRx utilities ; 5/26/2017 9:57am
;;7.0;OUTPATIENT PHARMACY;**508,598,581,631,617**;DEC 1997;Build 110
;
Q
; look for existing patient
; NAME - PATIENT FULL NAME
; IDOB - INCOMING PATIENT DOB
; IDGEN - INCOMING PATIENT GENDER
; SSN - INCOMING PATIENT SSN
; AL1 - INCOMING PATIENT ADDRESS LINE 1
FINDPAT(NAME,IDOB,IGEN,SSN,AL1) ;
N MPAT,MTCHCNT,PIEN,MATCH,PDOB,PGEN,PSSN,PAL1
; for now, quit if name match does not occur.
I '$D(^PS(52.46,"BN",NAME)) Q ""
S MTCHCNT=0
S PIEN=0 F S PIEN=$O(^PS(52.46,"BN",NAME,PIEN)) Q:'PIEN D
.S PDOB=$$GET1^DIQ(52.46,PIEN,.08,"I"),PGEN=$$GET1^DIQ(52.46,PIEN,.07,"I")
.S PSSN=$$GET1^DIQ(52.46,PIEN,1.4),PAL1=$$GET1^DIQ(52.46,PIEN,3.1,"E")
.; if the ssn exists, and does not match, quit
.I $L(SSN),SSN'=PSSN Q
.I PDOB=IDOB,PGEN=IGEN,AL1=PAL1 S MTCHCNT=MTCHCNT+1,MATCH(PIEN)=""
I MTCHCNT'=1 Q ""
S MPAT=$O(MATCH(0))
I MPAT Q MPAT
Q ""
;
FINDPRE(NAME,NPI,DEA) ; Try to find an existing prescriber record in #52.48
; Input: NAME - Prescriber Name
; NPI - Prescriber NPI Number
; DEA - Prescriber DEA Number
;Output: 0 - Prescriber not Found | NNN - Pointer to ERX EXTERNAL PERSON file (#52.48) for the matching Prescriber
N PREMTCH,FOUND
;
S NAME=$$UP^XLFSTR($G(NAME)),NPI=$G(NPI),DEA=$$UP^XLFSTR($G(DEA))
; If Name, NPI and DEA Number are present, entry must match all 3
I NAME'="",NPI'="",DEA'="" D Q +PREMTCH
.S (FOUND,PREMTCH)=0 F S PREMTCH=$O(^PS(52.48,"C",NPI,PREMTCH)) Q:'PREMTCH D I FOUND Q
..I NAME=$$GET1^DIQ(52.48,PREMTCH,.01),$D(^PS(52.48,"D",DEA,PREMTCH)) S FOUND=1
;
; If NPI and DEA Number are present, entry must match both
I NPI'="",DEA'="" D Q +PREMTCH
.S (FOUND,PREMTCH)=0 F S PREMTCH=$O(^PS(52.48,"C",NPI,PREMTCH)) Q:'PREMTCH D I FOUND Q
..I $D(^PS(52.48,"D",DEA,PREMTCH)) S FOUND=1
;
; If Name and NPI are present and DEA is missing, entry must match both (DEA must be blank)
I NAME'="",NPI'="",DEA="" D Q +PREMTCH
.S (FOUND,PREMTCH)=0 F S PREMTCH=$O(^PS(52.48,"C",NPI,PREMTCH)) Q:'PREMTCH D I FOUND Q
..I NAME=$$GET1^DIQ(52.48,PREMTCH,.01),$$GET1^DIQ(52.48,PREMTCH,1.6)="" S FOUND=1
;
; If Name and DEA are present and NPI is missing, entry must match both
I NAME'="",NPI="",DEA'="" D Q +PREMTCH
.S (FOUND,PREMTCH)=0 F S PREMTCH=$O(^PS(52.48,"C",NPI,PREMTCH)) Q:'PREMTCH D I FOUND Q
..I NAME=$$GET1^DIQ(52.48,PREMTCH,.01),$$GET1^DIQ(52.48,PREMTCH,1.6)=DEA S FOUND=1
;
; If only Name is present
I NAME'="",$O(^PS(52.48,"BN",NAME,0)) Q +$O(^PS(52.48,"BN",NAME,0))
;
Q 0
;
ERR(ERXIEN,MTYPE) ;
N GL,ECODE,DESCODE,ERRTEXT,DONE,I,REQIEN,REQTYP,ERXTYP,NWRXIEN
S GL=$NA(^TMP($J,"PSOERXO1","Message",0,"Body",0,MTYPE,0))
S ECODE=$G(@GL@("Code",0))
S ERRTEXT=$G(@GL@("Description",0))
S FDA(52.49,ERXIEN_",",60.1)=ECODE
S FDA(52.49,ERXIEN_",",60)=ERRTEXT
D FILE^DIE(,"FDA") K FDA
S DONE=0
F I=0:1 D Q:DONE D
.I '$D(@GL@("DescriptionCode",I)) S DONE=1 Q
.S DESCODE=$G(@GL@("DescriptionCode",I))
.S DESCODE=$$PRESOLV^PSOERXA1(DESCODE,"ERR") Q:'DESCODE
.Q:$D(^PS(52.49,ERXIEN,61,"B",DESCODE))
.S FDA(52.4961,"+1,"_ERXIEN_",",.01)=DESCODE D UPDATE^DIE(,"FDA") K FDA
S ERXTYP=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S REQIEN=$$RESOLV(ERXIEN)
I REQIEN D Q
.S REQTYP=$$GET1^DIQ(52.49,REQIEN,.08,"I")
.I REQTYP="CR" D UPDSTAT^PSOERXU1(ERXIEN,"CRE")
.I REQTYP="RR" D UPDSTAT^PSOERXU1(REQIEN,"RRE"),UPDSTAT^PSOERXU1(ERXIEN,"RRE")
.I REQTYP="CN" D UPDSTAT^PSOERXU1(REQIEN,"CNE"),UPDSTAT^PSOERXU1(ERXIEN,"CNE")
D UPDSTAT^PSOERXU1(ERXIEN,"E")
Q
GETSTAT(MTYPE,RTHID,RTMID) ;
N ESTAT,RTMTYPE,STFDA,RTMIEN,RESTAT
; if this is a cancel request, set the initial status to CAR - cancel request received
I MTYPE="CR" Q $$PRESOLV^PSOERXA1("CRN","ERX")
I MTYPE="CA" Q $$PRESOLV^PSOERXA1("CAR","ERX")
I 'RTHID,'RTMID S ESTAT=$S(MTYPE="RR":"RRN",MTYPE="RE":"RXR",MTYPE="N":"N",MTYPE="IE":"E",1:"N") Q $$PRESOLV^PSOERXA1(ESTAT,"ERX")
S RTMIEN=RTHID
I MTYPE="IE",'$L(RTMIEN) S ESTAT="E" Q $$PRESOLV^PSOERXA1(ESTAT,"ERX")
I MTYPE="IE",$L(RTMIEN) D
.S RTMTYPE=$$GET1^DIQ(52.49,RTMIEN,.08,"I")
.I RTMTYPE="CR" D UPDSTAT^PSOERXU1(RTMIEN,"CRE")
.I RTMTYPE="RR" S RESTAT=$$PRESOLV^PSOERXA1("RRE","ERX"),STFDA(52.49,RTMIEN_",",1)=RESTAT D UPDATE^DIE(,"STFDA") K STFDA Q
.S RESTAT=$$PRESOLV^PSOERXA1("E","ERX")
I MTYPE="RE",$L(RTMIEN) D
.S RTMTYPE=$$GET1^DIQ(52.49,RTMIEN,.08,"I")
.I RTMTYPE="RR" D UPDSTAT^PSOERXU1(RTMIEN,"RRR")
I MTYPE="CX",$L(RTMIEN) D
.S RTMTYPE=$$GET1^DIQ(52.49,RTMIEN,.08,"I")
.I RTMTYPE="CR",$$GET1^DIQ(52.49,RTMIEN,1,"E")'="CRR" D UPDSTAT^PSOERXU1(RTMIEN,"CRR")
I $G(ESTAT) Q ESTAT
S ESTAT=$S(MTYPE="CX":"CXN",MTYPE="RR":"RRN",MTYPE="RE":"RXN",MTYPE="N":"N",1:"N")
I ESTAT="" Q ""
I '$D(^PS(52.45,"C","ERX",ESTAT)) Q ""
Q $$PRESOLV^PSOERXA1(ESTAT,"ERX")
ADDCOMM(ERXIEN) ;
N DIR,Y,FDA,MTYPE
D FULL^VALM1
S VALMBCK="R"
I $D(^XUSEC("PSO ERX VIEW",DUZ)) W !,">>> Add Comments may not be selected at this point." D DIRE^PSOERXX1 Q
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
I "RR,RE,CA,CN,CR,CX"'[MTYPE!(MTYPE="N") S DIR(0)="E" W !!,"This option can only be used to add comments to request and response message",!,"types." D ^DIR K DIR Q
S DIR(0)="52.49,50",DIR("B")=$$GET1^DIQ(52.49,ERXIEN,50,"E") D ^DIR
Q:Y="^"!(Y="")
S FDA(52.49,ERXIEN_",",50)=Y
S FDA(52.49,ERXIEN_",",50.1)=DUZ
S FDA(52.49,ERXIEN_",",50.2)=$$NOW^XLFDT()
D FILE^DIE(,"FDA")
D INIT^PSOERX1
Q
RESOLV(IEN) ;
N RTHID,RTHIEN,RES
S RTHID=$$GET1^DIQ(52.49,IEN,.14,"E")
S RTHIEN=$$FIND1^DIC(52.49,,"O",RTHID,"FMID",,"RES")
I 'RTHIEN,$D(RES) Q "0^Could not find related message."
Q RTHIEN
GETREQ(IEN) ;
N RTMID,RTHIEN
S RTMID=$$GET1^DIQ(52.49,IEN,.02,"E")
S RTHIEN=$$FIND1^DIC(52.49,,"O",RTMID,"CHVID",,"RES")
I 'RTHIEN,$D(RES) Q "0^Could not find related message."
Q RTHIEN
GETRESP(IEN) ;
N MID,RTHIEN
S MID=$$GET1^DIQ(52.49,IEN,.01,"E")
S RTHIEN=$$FIND1^DIC(52.49,,"O",MID,"RTHID",,"RES")
I 'RTHIEN,$D(RES) Q "0^Could not find related message."
Q RTHIEN
MSGHIST(RES,IEN) ;
N SIEN,RELIEN
S SIEN=0
F S SIEN=$O(^PS(52.49,IEN,201,SIEN)) Q:'SIEN D
.S RELIEN=$$GET1^DIQ(52.49201,SIEN_","_IEN_",",.01,"I")
.S RES(RELIEN)=""
Q
; REFREQ - erx refill request IEN
; REFRES - erx refill response IEN
; Determine deltas between refill request and response.
RRDELTA(DELTAS,REFREQ,REFRES) ;
N FLDS,DONE,I,REQARY,RESARY,FLDNM,SFLDS,REQSIEN,FOUND,REQIENS,RESIENS,REQTYP,RESTYP,SFLD,SFLDS,FLDNM,SFLDNM,SREQVAL,SRESVAL
N REQDAT,RESDAT,FIELD,SFIELD,FLD,REQVAL,RESVAL,RESSIEN
; first check the top level items
S FLDS=".04;2.1;2.3"
S DONE=0
F I=1:1 D Q:DONE
.S FLD=$P(FLDS,";",I) I FLD="" S DONE=1 Q
.S REQVAL=$$GET1^DIQ(52.49,REFREQ,FLD,"E")
.S RESVAL=$$GET1^DIQ(52.49,REFRES,FLD,"E")
.I REQVAL=RESVAL Q
.D FIELD^DID(52.49,FLD,,"LABEL","FIELD")
.S FLDNM=$G(FIELD("LABEL")) Q:'$L(FLDNM)
.S DELTAS(52.49,FLDNM)=REQVAL_U_RESVAL
S SFLDS=".06;.07;2.1"
S (REQSIEN,FOUND)=0 F S REQSIEN=$O(^PS(52.49,REFREQ,49,REQSIEN)) Q:'REQSIEN!(FOUND) D
.S REQIENS=REQSIEN_","_REFREQ_","
.S REQTYP=$$GET1^DIQ(52.4949,REQIENS,.02,"I") I REQTYP="D" D S FOUND=1 Q
..D GETS^DIQ(52.4949,REQIENS,SFLDS,"E","REQDAT")
S (RESSIEN,FOUND)=0 F S RESSIEN=$O(^PS(52.49,REFRES,49,RESSIEN)) Q:'RESSIEN!(FOUND) D
.S RESIENS=RESSIEN_","_REFRES_","
.S RESTYP=$$GET1^DIQ(52.4949,RESIENS,.02,"I") I RESTYP="D" D S FOUND=1 Q
..D GETS^DIQ(52.4949,RESIENS,SFLDS,"E","RESDAT")
S DONE=0
F I=1:1 D Q:DONE
.S SFLD=$P(SFLDS,";",I) I SFLD="" S DONE=1 Q
.S (SREQVAL,SRESVAL)=""
.I $D(REQIENS) S SREQVAL=$G(REQDAT(52.4949,REQIENS,SFLD,"E"))
.I $D(RESIENS) S SRESVAL=$G(RESDAT(52.4949,RESIENS,SFLD,"E"))
.I SREQVAL=SRESVAL Q
.I $D(SRESVAL),SFLD=.06 S SRESVAL=$G(SRESVAL)-1
.D FIELD^DID(52.4949,SFLD,,"LABEL","SFIELD")
.S SFLDNM=$G(SFIELD("LABEL")) Q:'$L(SFLDNM)
.S DELTAS(52.4949,SFLDNM)=SREQVAL_U_SRESVAL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXU2 7941 printed Apr 09, 2024@21:37:29 Page 2
PSOERXU2 ;ALB/BWF - eRx utilities ; 5/26/2017 9:57am
+1 ;;7.0;OUTPATIENT PHARMACY;**508,598,581,631,617**;DEC 1997;Build 110
+2 ;
+3 QUIT
+4 ; look for existing patient
+5 ; NAME - PATIENT FULL NAME
+6 ; IDOB - INCOMING PATIENT DOB
+7 ; IDGEN - INCOMING PATIENT GENDER
+8 ; SSN - INCOMING PATIENT SSN
+9 ; AL1 - INCOMING PATIENT ADDRESS LINE 1
FINDPAT(NAME,IDOB,IGEN,SSN,AL1) ;
+1 NEW MPAT,MTCHCNT,PIEN,MATCH,PDOB,PGEN,PSSN,PAL1
+2 ; for now, quit if name match does not occur.
+3 IF '$DATA(^PS(52.46,"BN",NAME))
QUIT ""
+4 SET MTCHCNT=0
+5 SET PIEN=0
FOR
SET PIEN=$ORDER(^PS(52.46,"BN",NAME,PIEN))
if 'PIEN
QUIT
Begin DoDot:1
+6 SET PDOB=$$GET1^DIQ(52.46,PIEN,.08,"I")
SET PGEN=$$GET1^DIQ(52.46,PIEN,.07,"I")
+7 SET PSSN=$$GET1^DIQ(52.46,PIEN,1.4)
SET PAL1=$$GET1^DIQ(52.46,PIEN,3.1,"E")
+8 ; if the ssn exists, and does not match, quit
+9 IF $LENGTH(SSN)
IF SSN'=PSSN
QUIT
+10 IF PDOB=IDOB
IF PGEN=IGEN
IF AL1=PAL1
SET MTCHCNT=MTCHCNT+1
SET MATCH(PIEN)=""
End DoDot:1
+11 IF MTCHCNT'=1
QUIT ""
+12 SET MPAT=$ORDER(MATCH(0))
+13 IF MPAT
QUIT MPAT
+14 QUIT ""
+15 ;
FINDPRE(NAME,NPI,DEA) ; Try to find an existing prescriber record in #52.48
+1 ; Input: NAME - Prescriber Name
+2 ; NPI - Prescriber NPI Number
+3 ; DEA - Prescriber DEA Number
+4 ;Output: 0 - Prescriber not Found | NNN - Pointer to ERX EXTERNAL PERSON file (#52.48) for the matching Prescriber
+5 NEW PREMTCH,FOUND
+6 ;
+7 SET NAME=$$UP^XLFSTR($GET(NAME))
SET NPI=$GET(NPI)
SET DEA=$$UP^XLFSTR($GET(DEA))
+8 ; If Name, NPI and DEA Number are present, entry must match all 3
+9 IF NAME'=""
IF NPI'=""
IF DEA'=""
Begin DoDot:1
+10 SET (FOUND,PREMTCH)=0
FOR
SET PREMTCH=$ORDER(^PS(52.48,"C",NPI,PREMTCH))
if 'PREMTCH
QUIT
Begin DoDot:2
+11 IF NAME=$$GET1^DIQ(52.48,PREMTCH,.01)
IF $DATA(^PS(52.48,"D",DEA,PREMTCH))
SET FOUND=1
End DoDot:2
IF FOUND
QUIT
End DoDot:1
QUIT +PREMTCH
+12 ;
+13 ; If NPI and DEA Number are present, entry must match both
+14 IF NPI'=""
IF DEA'=""
Begin DoDot:1
+15 SET (FOUND,PREMTCH)=0
FOR
SET PREMTCH=$ORDER(^PS(52.48,"C",NPI,PREMTCH))
if 'PREMTCH
QUIT
Begin DoDot:2
+16 IF $DATA(^PS(52.48,"D",DEA,PREMTCH))
SET FOUND=1
End DoDot:2
IF FOUND
QUIT
End DoDot:1
QUIT +PREMTCH
+17 ;
+18 ; If Name and NPI are present and DEA is missing, entry must match both (DEA must be blank)
+19 IF NAME'=""
IF NPI'=""
IF DEA=""
Begin DoDot:1
+20 SET (FOUND,PREMTCH)=0
FOR
SET PREMTCH=$ORDER(^PS(52.48,"C",NPI,PREMTCH))
if 'PREMTCH
QUIT
Begin DoDot:2
+21 IF NAME=$$GET1^DIQ(52.48,PREMTCH,.01)
IF $$GET1^DIQ(52.48,PREMTCH,1.6)=""
SET FOUND=1
End DoDot:2
IF FOUND
QUIT
End DoDot:1
QUIT +PREMTCH
+22 ;
+23 ; If Name and DEA are present and NPI is missing, entry must match both
+24 IF NAME'=""
IF NPI=""
IF DEA'=""
Begin DoDot:1
+25 SET (FOUND,PREMTCH)=0
FOR
SET PREMTCH=$ORDER(^PS(52.48,"C",NPI,PREMTCH))
if 'PREMTCH
QUIT
Begin DoDot:2
+26 IF NAME=$$GET1^DIQ(52.48,PREMTCH,.01)
IF $$GET1^DIQ(52.48,PREMTCH,1.6)=DEA
SET FOUND=1
End DoDot:2
IF FOUND
QUIT
End DoDot:1
QUIT +PREMTCH
+27 ;
+28 ; If only Name is present
+29 IF NAME'=""
IF $ORDER(^PS(52.48,"BN",NAME,0))
QUIT +$ORDER(^PS(52.48,"BN",NAME,0))
+30 ;
+31 QUIT 0
+32 ;
ERR(ERXIEN,MTYPE) ;
+1 NEW GL,ECODE,DESCODE,ERRTEXT,DONE,I,REQIEN,REQTYP,ERXTYP,NWRXIEN
+2 SET GL=$NAME(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,MTYPE,0))
+3 SET ECODE=$GET(@GL@("Code",0))
+4 SET ERRTEXT=$GET(@GL@("Description",0))
+5 SET FDA(52.49,ERXIEN_",",60.1)=ECODE
+6 SET FDA(52.49,ERXIEN_",",60)=ERRTEXT
+7 DO FILE^DIE(,"FDA")
KILL FDA
+8 SET DONE=0
+9 FOR I=0:1
Begin DoDot:1
+10 IF '$DATA(@GL@("DescriptionCode",I))
SET DONE=1
QUIT
+11 SET DESCODE=$GET(@GL@("DescriptionCode",I))
+12 SET DESCODE=$$PRESOLV^PSOERXA1(DESCODE,"ERR")
if 'DESCODE
QUIT
+13 if $DATA(^PS(52.49,ERXIEN,61,"B",DESCODE))
QUIT
+14 SET FDA(52.4961,"+1,"_ERXIEN_",",.01)=DESCODE
DO UPDATE^DIE(,"FDA")
KILL FDA
End DoDot:1
if DONE
QUIT
Begin DoDot:1
End DoDot:1
+15 SET ERXTYP=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+16 SET REQIEN=$$RESOLV(ERXIEN)
+17 IF REQIEN
Begin DoDot:1
+18 SET REQTYP=$$GET1^DIQ(52.49,REQIEN,.08,"I")
+19 IF REQTYP="CR"
DO UPDSTAT^PSOERXU1(ERXIEN,"CRE")
+20 IF REQTYP="RR"
DO UPDSTAT^PSOERXU1(REQIEN,"RRE")
DO UPDSTAT^PSOERXU1(ERXIEN,"RRE")
+21 IF REQTYP="CN"
DO UPDSTAT^PSOERXU1(REQIEN,"CNE")
DO UPDSTAT^PSOERXU1(ERXIEN,"CNE")
End DoDot:1
QUIT
+22 DO UPDSTAT^PSOERXU1(ERXIEN,"E")
+23 QUIT
GETSTAT(MTYPE,RTHID,RTMID) ;
+1 NEW ESTAT,RTMTYPE,STFDA,RTMIEN,RESTAT
+2 ; if this is a cancel request, set the initial status to CAR - cancel request received
+3 IF MTYPE="CR"
QUIT $$PRESOLV^PSOERXA1("CRN","ERX")
+4 IF MTYPE="CA"
QUIT $$PRESOLV^PSOERXA1("CAR","ERX")
+5 IF 'RTHID
IF 'RTMID
SET ESTAT=$SELECT(MTYPE="RR":"RRN",MTYPE="RE":"RXR",MTYPE="N":"N",MTYPE="IE":"E",1:"N")
QUIT $$PRESOLV^PSOERXA1(ESTAT,"ERX")
+6 SET RTMIEN=RTHID
+7 IF MTYPE="IE"
IF '$LENGTH(RTMIEN)
SET ESTAT="E"
QUIT $$PRESOLV^PSOERXA1(ESTAT,"ERX")
+8 IF MTYPE="IE"
IF $LENGTH(RTMIEN)
Begin DoDot:1
+9 SET RTMTYPE=$$GET1^DIQ(52.49,RTMIEN,.08,"I")
+10 IF RTMTYPE="CR"
DO UPDSTAT^PSOERXU1(RTMIEN,"CRE")
+11 IF RTMTYPE="RR"
SET RESTAT=$$PRESOLV^PSOERXA1("RRE","ERX")
SET STFDA(52.49,RTMIEN_",",1)=RESTAT
DO UPDATE^DIE(,"STFDA")
KILL STFDA
QUIT
+12 SET RESTAT=$$PRESOLV^PSOERXA1("E","ERX")
End DoDot:1
+13 IF MTYPE="RE"
IF $LENGTH(RTMIEN)
Begin DoDot:1
+14 SET RTMTYPE=$$GET1^DIQ(52.49,RTMIEN,.08,"I")
+15 IF RTMTYPE="RR"
DO UPDSTAT^PSOERXU1(RTMIEN,"RRR")
End DoDot:1
+16 IF MTYPE="CX"
IF $LENGTH(RTMIEN)
Begin DoDot:1
+17 SET RTMTYPE=$$GET1^DIQ(52.49,RTMIEN,.08,"I")
+18 IF RTMTYPE="CR"
IF $$GET1^DIQ(52.49,RTMIEN,1,"E")'="CRR"
DO UPDSTAT^PSOERXU1(RTMIEN,"CRR")
End DoDot:1
+19 IF $GET(ESTAT)
QUIT ESTAT
+20 SET ESTAT=$SELECT(MTYPE="CX":"CXN",MTYPE="RR":"RRN",MTYPE="RE":"RXN",MTYPE="N":"N",1:"N")
+21 IF ESTAT=""
QUIT ""
+22 IF '$DATA(^PS(52.45,"C","ERX",ESTAT))
QUIT ""
+23 QUIT $$PRESOLV^PSOERXA1(ESTAT,"ERX")
ADDCOMM(ERXIEN) ;
+1 NEW DIR,Y,FDA,MTYPE
+2 DO FULL^VALM1
+3 SET VALMBCK="R"
+4 IF $DATA(^XUSEC("PSO ERX VIEW",DUZ))
WRITE !,">>> Add Comments may not be selected at this point."
DO DIRE^PSOERXX1
QUIT
+5 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+6 IF "RR,RE,CA,CN,CR,CX"'[MTYPE!(MTYPE="N")
SET DIR(0)="E"
WRITE !!,"This option can only be used to add comments to request and response message",!,"types."
DO ^DIR
KILL DIR
QUIT
+7 SET DIR(0)="52.49,50"
SET DIR("B")=$$GET1^DIQ(52.49,ERXIEN,50,"E")
DO ^DIR
+8 if Y="^"!(Y="")
QUIT
+9 SET FDA(52.49,ERXIEN_",",50)=Y
+10 SET FDA(52.49,ERXIEN_",",50.1)=DUZ
+11 SET FDA(52.49,ERXIEN_",",50.2)=$$NOW^XLFDT()
+12 DO FILE^DIE(,"FDA")
+13 DO INIT^PSOERX1
+14 QUIT
RESOLV(IEN) ;
+1 NEW RTHID,RTHIEN,RES
+2 SET RTHID=$$GET1^DIQ(52.49,IEN,.14,"E")
+3 SET RTHIEN=$$FIND1^DIC(52.49,,"O",RTHID,"FMID",,"RES")
+4 IF 'RTHIEN
IF $DATA(RES)
QUIT "0^Could not find related message."
+5 QUIT RTHIEN
GETREQ(IEN) ;
+1 NEW RTMID,RTHIEN
+2 SET RTMID=$$GET1^DIQ(52.49,IEN,.02,"E")
+3 SET RTHIEN=$$FIND1^DIC(52.49,,"O",RTMID,"CHVID",,"RES")
+4 IF 'RTHIEN
IF $DATA(RES)
QUIT "0^Could not find related message."
+5 QUIT RTHIEN
GETRESP(IEN) ;
+1 NEW MID,RTHIEN
+2 SET MID=$$GET1^DIQ(52.49,IEN,.01,"E")
+3 SET RTHIEN=$$FIND1^DIC(52.49,,"O",MID,"RTHID",,"RES")
+4 IF 'RTHIEN
IF $DATA(RES)
QUIT "0^Could not find related message."
+5 QUIT RTHIEN
MSGHIST(RES,IEN) ;
+1 NEW SIEN,RELIEN
+2 SET SIEN=0
+3 FOR
SET SIEN=$ORDER(^PS(52.49,IEN,201,SIEN))
if 'SIEN
QUIT
Begin DoDot:1
+4 SET RELIEN=$$GET1^DIQ(52.49201,SIEN_","_IEN_",",.01,"I")
+5 SET RES(RELIEN)=""
End DoDot:1
+6 QUIT
+7 ; REFREQ - erx refill request IEN
+8 ; REFRES - erx refill response IEN
+9 ; Determine deltas between refill request and response.
RRDELTA(DELTAS,REFREQ,REFRES) ;
+1 NEW FLDS,DONE,I,REQARY,RESARY,FLDNM,SFLDS,REQSIEN,FOUND,REQIENS,RESIENS,REQTYP,RESTYP,SFLD,SFLDS,FLDNM,SFLDNM,SREQVAL,SRESVAL
+2 NEW REQDAT,RESDAT,FIELD,SFIELD,FLD,REQVAL,RESVAL,RESSIEN
+3 ; first check the top level items
+4 SET FLDS=".04;2.1;2.3"
+5 SET DONE=0
+6 FOR I=1:1
Begin DoDot:1
+7 SET FLD=$PIECE(FLDS,";",I)
IF FLD=""
SET DONE=1
QUIT
+8 SET REQVAL=$$GET1^DIQ(52.49,REFREQ,FLD,"E")
+9 SET RESVAL=$$GET1^DIQ(52.49,REFRES,FLD,"E")
+10 IF REQVAL=RESVAL
QUIT
+11 DO FIELD^DID(52.49,FLD,,"LABEL","FIELD")
+12 SET FLDNM=$GET(FIELD("LABEL"))
if '$LENGTH(FLDNM)
QUIT
+13 SET DELTAS(52.49,FLDNM)=REQVAL_U_RESVAL
End DoDot:1
if DONE
QUIT
+14 SET SFLDS=".06;.07;2.1"
+15 SET (REQSIEN,FOUND)=0
FOR
SET REQSIEN=$ORDER(^PS(52.49,REFREQ,49,REQSIEN))
if 'REQSIEN!(FOUND)
QUIT
Begin DoDot:1
+16 SET REQIENS=REQSIEN_","_REFREQ_","
+17 SET REQTYP=$$GET1^DIQ(52.4949,REQIENS,.02,"I")
IF REQTYP="D"
Begin DoDot:2
+18 DO GETS^DIQ(52.4949,REQIENS,SFLDS,"E","REQDAT")
End DoDot:2
SET FOUND=1
QUIT
End DoDot:1
+19 SET (RESSIEN,FOUND)=0
FOR
SET RESSIEN=$ORDER(^PS(52.49,REFRES,49,RESSIEN))
if 'RESSIEN!(FOUND)
QUIT
Begin DoDot:1
+20 SET RESIENS=RESSIEN_","_REFRES_","
+21 SET RESTYP=$$GET1^DIQ(52.4949,RESIENS,.02,"I")
IF RESTYP="D"
Begin DoDot:2
+22 DO GETS^DIQ(52.4949,RESIENS,SFLDS,"E","RESDAT")
End DoDot:2
SET FOUND=1
QUIT
End DoDot:1
+23 SET DONE=0
+24 FOR I=1:1
Begin DoDot:1
+25 SET SFLD=$PIECE(SFLDS,";",I)
IF SFLD=""
SET DONE=1
QUIT
+26 SET (SREQVAL,SRESVAL)=""
+27 IF $DATA(REQIENS)
SET SREQVAL=$GET(REQDAT(52.4949,REQIENS,SFLD,"E"))
+28 IF $DATA(RESIENS)
SET SRESVAL=$GET(RESDAT(52.4949,RESIENS,SFLD,"E"))
+29 IF SREQVAL=SRESVAL
QUIT
+30 IF $DATA(SRESVAL)
IF SFLD=.06
SET SRESVAL=$GET(SRESVAL)-1
+31 DO FIELD^DID(52.4949,SFLD,,"LABEL","SFIELD")
+32 SET SFLDNM=$GET(SFIELD("LABEL"))
if '$LENGTH(SFLDNM)
QUIT
+33 SET DELTAS(52.4949,SFLDNM)=SREQVAL_U_SRESVAL
End DoDot:1
if DONE
QUIT
+34 QUIT
