PSOERXU2 ;ALB/BWF - eRx utilities ; 5/26/2017 9:57am
;;7.0;OUTPATIENT PHARMACY;**508,598,581,631,617,746**;DEC 1997;Build 106
;
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,DA
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
K DA 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 REF^PSOERSE1
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
CANREQ(ERXIEN,LINE,PMODE) ;
N REQIEN,REQDTTM,COMM,HUBID,CANSTAT,DNB,RESTYPE,COMM,COMMARY,COMMBY,COMMDTTM,CTXT,I,REQBY
; - the next line of code will actually reference the related message for retrieval of the cancel request information
; - check that this is correct and test.
S REQIEN=ERXIEN
I $$GET1^DIQ(52.49,ERXIEN,.08,"I")="CN" S REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
I '$$FINDNRX^PSOERXU6(REQIEN) S DNB=1
S HUBID=$$GET1^DIQ(52.49,REQIEN,.01,"E")
S REQBY=$$GET1^DIQ(52.49,REQIEN,2.1,"E")
S REQDTTM=$$GET1^DIQ(52.49,REQIEN,.03,"E")
;S DNB=$$GET1^DIQ(52.49,REQIEN,80.5,"I")
S COMM=$$GET1^DIQ(52.49,REQIEN,50,"E")
S RESTYPE=$$GET1^DIQ(52.49,REQIEN,52.1,"E")
S CANSTAT=$$GET1^DIQ(52.49,REQIEN,1,"I")
S CANSTAT=$$GET1^DIQ(52.45,CANSTAT,.02,"E")
I '$G(SDERXFLG) S LINE=LINE+1 D SET^VALM10(LINE,"")
S LINE=LINE+1 D SET^VALM10(LINE,"************************CANCEL REQUEST INFORMATION**************************")
I $G(SDERXFLG) D SET^VALM10(LINE," CANCEL REQUEST INFORMATION "),CNTRL^VALM10(LINE,1,80,$G(IOUON)_$G(IOINHI),$G(IOUOFF)_$G(IOINORM))
S LINE=LINE+1 D SET^VALM10(LINE,RESTYPE),CNTRL^VALM10(LINE,1,$L(RESTYPE),$G(IORVON),$G(IORVOFF))
S LINE=LINE+1 D SET^VALM10(LINE,"Request Status: "_CANSTAT),CNTRL^VALM10(LINE,17,$L(CANSTAT),$G(IOINHI),$G(IOINORM))
I $L(RESTYPE) S LINE=LINE+1 D SET^VALM10(LINE,"Request/Response Type: "_RESTYPE),CNTRL^VALM10(LINE,23,$L(RESTYPE),$G(IOINHI),$G(IOINORM))
S LINE=LINE+1 D SET^VALM10(LINE,"Requested By: "_REQBY),CNTRL^VALM10(LINE,15,$L(REQBY),$G(IOINHI),$G(IOINORM))
S LINE=LINE+1 D SET^VALM10(LINE,"Request Date/Time: "_REQDTTM),CNTRL^VALM10(LINE,20,$L(REQDTTM),$G(IOINHI),$G(IOINORM))
I $G(DNB) S LINE=LINE+1 D SET^VALM10(LINE,"Original eRx not found in Hub and/or in Vista."),CNTRL^VALM10(LINE,1,80,$G(IOINHI),$G(IOINORM))
I '$G(SDERXFLG) S LINE=LINE+1 D SET^VALM10(LINE,"")
S COMM=$$GET1^DIQ(52.49,REQIEN,50,"E")
S COMM="Request Comments: "_COMM
D TXT2ARY^PSOERXD1(.COMMARY,COMM," ",80)
S I=0 F S I=$O(COMMARY(I)) Q:'I D
.S CTXT=$G(COMMARY(I))
.S LINE=LINE+1 D SET^VALM10(LINE,CTXT)
.I I=1 D CNTRL^VALM10(LINE,19,$L(CTXT),$G(IOINHI),$G(IOINORM)) Q
.D CNTRL^VALM10(LINE,1,$L(CTXT),$G(IOINHI),$G(IOINORM))
S COMMBY=$$GET1^DIQ(52.49,REQIEN,50.1,"E")
S COMMDTTM=$$GET1^DIQ(52.49,REQIEN,50.2,"E")
S LINE=LINE+1 D SET^VALM10(LINE,"Comments By: "_COMMBY),CNTRL^VALM10(LINE,14,$L(COMMBY),$G(IOINHI),$G(IOINORM))
S LINE=LINE+1 D SET^VALM10(LINE,"Comments Date/Time: "_COMMDTTM),CNTRL^VALM10(LINE,21,$L(COMMDTTM),$G(IOINHI),$G(IOINORM))
I '$G(SDERXFLG) S LINE=LINE+1 D SET^VALM10(LINE,"")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXU2 10604 printed Dec 13, 2024@02:29:03 Page 2
PSOERXU2 ;ALB/BWF - eRx utilities ; 5/26/2017 9:57am
+1 ;;7.0;OUTPATIENT PHARMACY;**508,598,581,631,617,746**;DEC 1997;Build 106
+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,DA
+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 KILL DA
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 REF^PSOERSE1
+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
CANREQ(ERXIEN,LINE,PMODE) ;
+1 NEW REQIEN,REQDTTM,COMM,HUBID,CANSTAT,DNB,RESTYPE,COMM,COMMARY,COMMBY,COMMDTTM,CTXT,I,REQBY
+2 ; - the next line of code will actually reference the related message for retrieval of the cancel request information
+3 ; - check that this is correct and test.
+4 SET REQIEN=ERXIEN
+5 IF $$GET1^DIQ(52.49,ERXIEN,.08,"I")="CN"
SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
+6 IF '$$FINDNRX^PSOERXU6(REQIEN)
SET DNB=1
+7 SET HUBID=$$GET1^DIQ(52.49,REQIEN,.01,"E")
+8 SET REQBY=$$GET1^DIQ(52.49,REQIEN,2.1,"E")
+9 SET REQDTTM=$$GET1^DIQ(52.49,REQIEN,.03,"E")
+10 ;S DNB=$$GET1^DIQ(52.49,REQIEN,80.5,"I")
+11 SET COMM=$$GET1^DIQ(52.49,REQIEN,50,"E")
+12 SET RESTYPE=$$GET1^DIQ(52.49,REQIEN,52.1,"E")
+13 SET CANSTAT=$$GET1^DIQ(52.49,REQIEN,1,"I")
+14 SET CANSTAT=$$GET1^DIQ(52.45,CANSTAT,.02,"E")
+15 IF '$GET(SDERXFLG)
SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+16 SET LINE=LINE+1
DO SET^VALM10(LINE,"************************CANCEL REQUEST INFORMATION**************************")
+17 IF $GET(SDERXFLG)
DO SET^VALM10(LINE," CANCEL REQUEST INFORMATION ")
DO CNTRL^VALM10(LINE,1,80,$GET(IOUON)_$GET(IOINHI),$GET(IOUOFF)_$GET(IOINORM))
+18 SET LINE=LINE+1
DO SET^VALM10(LINE,RESTYPE)
DO CNTRL^VALM10(LINE,1,$LENGTH(RESTYPE),$GET(IORVON),$GET(IORVOFF))
+19 SET LINE=LINE+1
DO SET^VALM10(LINE,"Request Status: "_CANSTAT)
DO CNTRL^VALM10(LINE,17,$LENGTH(CANSTAT),$GET(IOINHI),$GET(IOINORM))
+20 IF $LENGTH(RESTYPE)
SET LINE=LINE+1
DO SET^VALM10(LINE,"Request/Response Type: "_RESTYPE)
DO CNTRL^VALM10(LINE,23,$LENGTH(RESTYPE),$GET(IOINHI),$GET(IOINORM))
+21 SET LINE=LINE+1
DO SET^VALM10(LINE,"Requested By: "_REQBY)
DO CNTRL^VALM10(LINE,15,$LENGTH(REQBY),$GET(IOINHI),$GET(IOINORM))
+22 SET LINE=LINE+1
DO SET^VALM10(LINE,"Request Date/Time: "_REQDTTM)
DO CNTRL^VALM10(LINE,20,$LENGTH(REQDTTM),$GET(IOINHI),$GET(IOINORM))
+23 IF $GET(DNB)
SET LINE=LINE+1
DO SET^VALM10(LINE,"Original eRx not found in Hub and/or in Vista.")
DO CNTRL^VALM10(LINE,1,80,$GET(IOINHI),$GET(IOINORM))
+24 IF '$GET(SDERXFLG)
SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+25 SET COMM=$$GET1^DIQ(52.49,REQIEN,50,"E")
+26 SET COMM="Request Comments: "_COMM
+27 DO TXT2ARY^PSOERXD1(.COMMARY,COMM," ",80)
+28 SET I=0
FOR
SET I=$ORDER(COMMARY(I))
if 'I
QUIT
Begin DoDot:1
+29 SET CTXT=$GET(COMMARY(I))
+30 SET LINE=LINE+1
DO SET^VALM10(LINE,CTXT)
+31 IF I=1
DO CNTRL^VALM10(LINE,19,$LENGTH(CTXT),$GET(IOINHI),$GET(IOINORM))
QUIT
+32 DO CNTRL^VALM10(LINE,1,$LENGTH(CTXT),$GET(IOINHI),$GET(IOINORM))
End DoDot:1
+33 SET COMMBY=$$GET1^DIQ(52.49,REQIEN,50.1,"E")
+34 SET COMMDTTM=$$GET1^DIQ(52.49,REQIEN,50.2,"E")
+35 SET LINE=LINE+1
DO SET^VALM10(LINE,"Comments By: "_COMMBY)
DO CNTRL^VALM10(LINE,14,$LENGTH(COMMBY),$GET(IOINHI),$GET(IOINORM))
+36 SET LINE=LINE+1
DO SET^VALM10(LINE,"Comments Date/Time: "_COMMDTTM)
DO CNTRL^VALM10(LINE,21,$LENGTH(COMMDTTM),$GET(IOINHI),$GET(IOINORM))
+37 IF '$GET(SDERXFLG)
SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+38 QUIT
