PSOERXA2 ;ALB/BWF - eRx Utilities/RPC's ; 8/3/2016 5:14pm
;;7.0;OUTPATIENT PHARMACY;**467,520,508**;DEC 1997;Build 295
;
Q
;/BLB/ PSO*7.0*520 - BEGIN CHANGE ( ADD BOTH THE 'FAC' AND 'FIC' LINETAG TO YOUR ROUTINE )
FAC(ERXIEN) ; facility
N GL,IDTYPE,IDVAL,F,FIEN,IENS,FNAME,FACFDA,AL1,AL2,CITY,STATE,ZIP,PLQUAL,FACFDA,SIEN
S GL=$NA(^TMP($J,"PSOERXO1","Message",0,"Body",0,"NewRx",0,"Facility",0))
S F=52.49,FIEN="",IENS=ERXIEN_","
S FNAME=$G(@GL@("FacilityName",0))
S FACFDA(F,IENS,70.1)=FNAME
S AL1=$G(@GL@("Address",0,"AddressLine1",0)),FACFDA(F,IENS,70.2)=AL1
S AL2=$G(@GL@("Address",0,"AddressLine2",0)),FACFDA(F,IENS,70.3)=AL2
S CITY=$G(@GL@("Address",0,"City",0)),FACFDA(F,IENS,70.4)=CITY
S STATE=$G(@GL@("Address",0,"State",0))
S ZIP=$G(@GL@("Address",0,"ZipCode",0)),FACFDA(F,IENS,70.6)=ZIP
S SIEN=$$STRES(ZIP,STATE)
S FACFDA(F,IENS,70.5)=SIEN
S PLQUAL=$G(@GL@("Address",0,"PlaceLocationQualifier",0)),FACFDA(F,IENS,70.7)=PLQUAL
D FILE^DIE(,"FACFDA","ERR") K FACFDA ;D FIC($P(FIEN,","))
D FIC(ERXIEN)
; future enhancement - file ID types - requires modification to the current payer information subfile
; - THIS REQUIRES RESOLUTION OF THE PAYERID TYPE ISSUE ALONG WITH PRIOR AUTH VALUES, ETC.
;S IDTYPE="" F S IDTYPE=$O(@GL@("Identification",0,IDTYPE)) Q:IDTYPE="" D
;S IDVAL=$G(@GL@("Identification",0,IDTYPE,0))
Q
FIC(IEN) ;
N IDTYP,IDVAL,FDA,I,CCNT,FIEN,FACFDA,IDCNT,ERR
Q:'IEN
S IENS=IEN_","
S IDCNT=0
K ^PS(52.49,IEN,71)
S IDNM="" F S IDNM=$O(@GL@("Identification",0,IDNM)) Q:IDNM="" D
.S IDVAL=$G(@GL@("Identification",0,IDNM,0))
.I IDNM="NCPDPID",$G(NCPDPID)']"" S NCPDPID=$G(IDVAL)
.S IDARY(IDNM)=IDVAL
.S IDFND=0
.S SRCH=0 F S SRCH=$O(^PS(52.49,IEN,71,SRCH)) Q:'SRCH D
..I $$GET1^DIQ(52.4971,SRCH_","_IEN_",",.01)=IDNM D
...S IDFND=1
...S FACFDA(52.4971,SRCH_","_IEN_",",.02)=IDVAL D FILE^DIE(,"FACFDA","ERR") K FACFDA
.Q:IDFND
.S FACFDA(52.4971,"+1,"_IEN_",",.01)=IDNM
.S FACFDA(52.4971,"+1,"_IEN_",",.02)=IDVAL
.D UPDATE^DIE(,"FACFDA") K FACFDA
; clear out existing communication Numbers
K ^PS(52.49,IEN,72)
S I=-1 F S I=$O(@GL@("CommunicationNumbers",0,"Communication",I)) Q:I="" D
.S CCNT=$G(CCNT)+1
.S COMVAL=$G(@GL@("CommunicationNumbers",0,"Communication",I,"Number",0))
.S COMTYP=$G(@GL@("CommunicationNumbers",0,"Communication",I,"Qualifier",0))
.S FACFDA(52.4972,"+"_CCNT_","_IEN_",",.01)=COMVAL
.S FACFDA(52.4972,"+"_CCNT_","_IEN_",",.02)=COMTYP
D UPDATE^DIE(,"FACFDA") K FACFDA
Q
;/BLB/ PSO*7.0*520 - END CHANGE
PHR(ERXIEN,MTYPE) ; pharamcy
N GL,SNAME,AL1,AL2,CIT,STATE,ZIP,PLQUAL,COMTYP,COMVAL,I,F,EIENS,PHIEN,CCNT,NEW,SPEC,FDA,NEWPHIEN,GL2,FQUAL,FROM,SIEN
N NCPDPID
S GL=$NA(^TMP($J,"PSOERXO1","Message",0,"Body",0,MTYPE,0,"Pharmacy",0))
S GL2=$NA(^TMP($J,"PSOERXO1","Message","A","Qualifier","Header","A","Qualifier"))
S FQUAL=$G(@GL2@("From","A","Qualifier"))
S FROM=$G(@GL@("From",0))
I FQUAL="P",FROM]"" S NCPDPID=FROM
S F=52.47,PHIEN=""
S EIENS=ERXIEN_","
S SNAME=$G(@GL@("StoreName",0))
Q:'$L(SNAME)
I $D(^PS(52.47,"B",SNAME)) S PHIEN=$O(^PS(52.47,"B",SNAME,0)) I PHIEN S PHIEN=PHIEN_",",NEW=0
; if we found a match, clear out the existing communication numbers and identification
I PHIEN K ^PS(52.47,$P(PHIEN,","),3),^PS(52.47,$P(PHIEN,","),2)
I '$G(PHIEN) S PHIEN="+1,",NEW=1,FDA(F,PHIEN,.01)=SNAME
S FDA(F,PHIEN,.05)=SNAME
S SPEC=$G(@GL@("Specialty",0)),FDA(F,PHIEN,1.8)=SPEC
S AL1=$G(@GL@("Address",0,"AddressLine1",0)),FDA(F,PHIEN,1.1)=AL1
S AL2=$G(@GL@("Address",0,"AddressLine2",0)),FDA(F,PHIEN,1.2)=AL2
S CITY=$G(@GL@("Address",0,"City",0)),FDA(F,PHIEN,1.3)=CITY
S STATE=$G(@GL@("Address",0,"State",0))
S ZIP=$G(@GL@("Address",0,"ZipCode",0)),FDA(F,PHIEN,1.5)=ZIP
S SIEN=$$STRES(ZIP,STATE)
S FDA(F,PHIEN,1.4)=SIEN
S PLQUAL=$G(@GL@("Address",0,"PlaceLocationQualifier",0)),FDA(F,PHIEN,1.7)=PLQUAL
; if this is an existing pharmacy entry, file the updates, communication values, and identification, then link to 52.49
I 'NEW D Q
.D FILE^DIE(,"FDA") K FDA D PHRIC($P(PHIEN,","))
.S FDA(52.49,EIENS,2.5)=$P(PHIEN,",") D FILE^DIE(,"FDA") K FDA
; for a new entry, file the entry, then file communication/identification and link to 52.49
D UPDATE^DIE(,"FDA","NEWPHIEN") K FDA
S PHIEN=$O(NEWPHIEN(0)),PHIEN=$G(NEWPHIEN(PHIEN))
Q:'PHIEN
D PHRIC(PHIEN)
S FDA(52.49,EIENS,2.5)=PHIEN D FILE^DIE(,"FDA") K FDA
Q
PHRIC(IEN) ; pharmacy identification and communication information
N IDTYP,IDVAL,FDA,I,CCNT,PHIEN,FDA,IDCNT
Q:'IEN
S PHIEN=IEN_","
S IDCNT=0
K ^PS(52.47,IEN,2)
S IDNM="" F S IDNM=$O(@GL@("Identification",0,IDNM)) Q:IDNM="" D
.S IDVAL=$G(@GL@("Identification",0,IDNM,0))
.I IDNM="NCPDPID",$G(NCPDPID)']"" S NCPDPID=$G(IDVAL)
.S IDARY(IDNM)=IDVAL
.S IDFND=0
.S SRCH=0 F S SRCH=$O(^PS(52.47,IEN,2,SRCH)) Q:'SRCH D
..I $$GET1^DIQ(52.472,SRCH_","_IEN_",",.01)=IDNM D
...S IDFND=1
...S FDA(52.472,SRCH_","_IEN_",",.02)=IDVAL D FILE^DIE(,"FDA") K FDA
.Q:IDFND
.S FDA(52.472,"+1,"_IEN_",",.01)=IDNM
.S FDA(52.472,"+1,"_IEN_",",.02)=IDVAL
.D UPDATE^DIE(,"FDA") K FDA
I $G(NCPDPID)]"" S FDA(52.47,PHIEN,.02)=NCPDPID D FILE^DIE(,"FDA") K FDA
; clear out existing communication Numbers
K ^PS(52.47,IEN,3)
S I=-1 F S I=$O(@GL@("CommunicationNumbers",0,"Communication",I)) Q:I="" D
.S CCNT=$G(CCNT)+1
.S COMVAL=$G(@GL@("CommunicationNumbers",0,"Communication",I,"Number",0))
.S COMTYP=$G(@GL@("CommunicationNumbers",0,"Communication",I,"Qualifier",0))
.S FDA(52.473,"+"_CCNT_","_PHIEN,.01)=COMVAL
.S FDA(52.473,"+"_CCNT_","_PHIEN,.02)=COMTYP
D UPDATE^DIE(,"FDA") K FDA
Q
PRE(ERXIEN,MTYPE) ; prescriber
N GL,FN,LN,MN,SUFF,PREF,AL1,AL2,CITY,STATE,ZIP,IDDONE,I,IDNM,IDVAL,C,CQUAL,CVAL,SPEC,AFN,ALN,AMN,APREF,ASUFF,FULLNM
N EIENS,FDA,NPIEN,NEW,PRVIEN,PRVIENS,NEWIEN,IDFND,SRCH,PNPI,PDEA,GL2,FQUAL,FROM,SIEN
S GL=$NA(^TMP($J,"PSOERXO1","Message",0,"Body",0,MTYPE,0,"Prescriber",0))
S GL2=$NA(^TMP($J,"PSOERXO1","Message","A","Qualifier","Header","A","Qualifier"))
S FQUAL=$G(@GL2@("From","A","Qualifier"))
S FROM=$G(@GL@("From",0))
I FQUAL="D",FROM]"" S PNPI=FROM
S F=52.48
S EIENS=ERXIEN_","
S FN=$$UP^XLFSTR($G(@GL@("Name",0,"FirstName",0)))
S LN=$$UP^XLFSTR($G(@GL@("Name",0,"LastName",0)))
S MN=$$UP^XLFSTR($G(@GL@("Name",0,"MiddleName",0)))
S FULLNM=LN_","_FN_$S(MN]"":" "_MN,1:"")
S SUFF=$$UP^XLFSTR($G(@GL@("Name",0,"Suffix",0)))
S PREF=$$UP^XLFSTR($G(@GL@("Name",0,"Prefix",0)))
S AL1=$G(@GL@("Address",0,"AddressLine1",0))
S AL2=$G(@GL@("Address",0,"AddressLine2",0))
S CITY=$G(@GL@("Address",0,"City",0))
S STATE=$G(@GL@("Address",0,"State",0))
S ZIP=$G(@GL@("Address",0,"ZipCode",0))
S SIEN=$$STRES(ZIP,STATE)
S SPEC=$G(@GL@("Specialty",0))
S AFN=$$UP^XLFSTR($G(@GL@("PrescriberAgent",0,"FirstName",0)))
S ALN=$$UP^XLFSTR($G(@GL@("PrescriberAgent",0,"LastName",0)))
S AMN=$$UP^XLFSTR($G(@GL@("PrescriberAgent",0,"MiddleName",0)))
S APREF=$$UP^XLFSTR($G(@GL@("PrescriberAgent",0,"Prefix",0)))
S ASUFF=$$UP^XLFSTR($G(@GL@("PrescriberAgent",0,"Suffix",0)))
; try to match the provider/supervisor. if no match, create a new entry for this provider
; if there is no NPI, grab it from the Identification multiple.
I '$G(PNPI) S PNPI=$G(@GL@("Identification",0,"NPI",0))
S PDEA=$G(@GL@("Identification",0,"DEANumber",0))
S STLIC=$G(@GL@("Identification",0,"StateLicenseNumber",0))
S PRVIEN=$$FINDPRE^PSOERXU2(FULLNM,$G(PNPI),PDEA) I PRVIEN S NEW=0
I 'PRVIEN S NEW=1,PRVIEN="+1"
S PRVIENS=PRVIEN_","
S FDA(F,PRVIENS,.01)=FULLNM,FDA(F,PRVIENS,.02)=LN,FDA(F,PRVIENS,.03)=FN,FDA(F,PRVIENS,.04)=MN,FDA(F,PRVIENS,.05)=SUFF
S FDA(F,PRVIENS,.06)=PREF,FDA(F,PRVIENS,4.1)=AL1,FDA(F,PRVIENS,4.2)=AL2,FDA(F,PRVIENS,4.3)=CITY
S FDA(F,PRVIENS,4.4)=SIEN,FDA(F,PRVIENS,4.5)=ZIP
S FDA(F,PRVIENS,5.1)=ALN,FDA(F,PRVIENS,5.2)=AFN,FDA(F,PRVIENS,5.3)=AMN,FDA(F,PRVIENS,5.4)=ASUFF,FDA(F,PRVIENS,5.5)=APREF
S FDA(F,PRVIENS,1.2)=SPEC
S FDA(F,PRVIENS,1.8)=$G(STLIC)
S FDA(F,PRVIENS,1.1)="PR"
I 'NEW D Q
.D FILE^DIE(,"FDA")
.D PRVCI(PRVIEN)
.S FDA(52.49,EIENS,2.1)=PRVIEN D FILE^DIE(,"FDA") K FDA
D UPDATE^DIE(,"FDA","NEWIEN") K FDA
S NPIEN=$O(NEWIEN(0)),NPIEN=$G(NEWIEN(NPIEN))
D PRVCI(NPIEN)
S FDA(52.49,EIENS,2.1)=NPIEN D FILE^DIE(,"FDA") K FDA
Q
PRVCI(IEN) ;
N IENS,C,CQUAL,CVAL,FDA,IDNM,IDVAL,IDARY,IDFND,SRCH,NCPDPID,PHIN,DEA,STLIC,PNPI
S IENS=IEN_","
; kill off existing data
K ^PS(52.48,IEN,3)
S C=-1 F S C=$O(@GL@("CommunicationNumbers",0,"Communication",C)) Q:C="" D
.S CQUAL=$G(@GL@("CommunicationNumbers",0,"Communication",C,"Qualifier",0))
.S CVAL=$G(@GL@("CommunicationNumbers",0,"Communication",C,"Number",0))
.S FDA(52.483,"+1,"_IENS,.01)=CVAL
.S FDA(52.483,"+1,"_IENS,.02)=CQUAL
.D UPDATE^DIE(,"FDA") K FDA
; kill existing Identification data.
K ^PS(52.48,IEN,6)
S IDNM="" F S IDNM=$O(@GL@("Identification",0,IDNM)) Q:IDNM="" D
.S IDVAL=$G(@GL@("Identification",0,IDNM,0))
.S IDARY(IDNM)=IDVAL
.I IDNM="NCPDPID" S NCPDPID=IDVAL
.I IDNM="HIN" S PHIN=IDVAL
.I IDNM="DEANumber" S DEA=IDVAL
.I IDNM="StateLicenseNumber" S STLIC=IDVAL
.I IDNM="NPI" S PNPI=IDVAL
.S IDFND=0
.S SRCH=0 F S SRCH=$O(^PS(52.48,IEN,6,SRCH)) Q:'SRCH D
..I $$GET1^DIQ(52.486,SRCH_","_IEN_",",.01)=IDNM D
...S IDFND=1
...S FDA(52.486,SRCH_","_IEN_",",.02)=IDVAL D FILE^DIE(,"FDA") K FDA
.Q:IDFND
.S FDA(52.486,"+1,"_IEN_",",.01)=IDNM
.S FDA(52.486,"+1,"_IEN_",",.02)=IDVAL
.D UPDATE^DIE(,"FDA") K FDA
S FDA(52.48,IENS,1.4)=$G(NCPDPID),FDA(52.48,IENS,1.5)=$G(PNPI),FDA(52.48,IENS,1.6)=$G(DEA),FDA(52.48,IENS,1.7)=$G(PHIN)
D FILE^DIE(,"FDA") K FDA
Q
REQ ; request
N GL,CRTYPE,RETREC,RRNUM
S GL=$NA(^TMP($J,"PSOERXO1","Message",0,"Body",0,"NewRx",0,"Request",0))
S CRTYPE=$G(@GL@("ChangeRequestType",0))
S RETREC=$G(@GL@("ReturnReceipt",0))
S RRNUM=$G(@GL@("RequestReferenceNumber",0))
; FUTURE ENHANCEMENT - file this information when we are getting other request types.
Q
SUP(ERXIEN,MTYPE) ; supervisor
N GL,FN,LN,MN,SUFF,PREF,AL1,AL2,CITY,STATE,ZIP,IDDONE,I,IDNM,IDVAL,C,CQUAL,CVAL,SPEC,AFN,ALN,AMN,APREF,ASUFF,EIENS
N FDA,NPIEN,NEW,PRVIEN,PRVIENS,NEWIEN,FDA,IDFND,SRCH,PNPI,PDEA,STLIC,SIEN
S GL=$NA(^TMP($J,"PSOERXO1","Message",0,"Body",0,MTYPE,0,"Supervisor",0))
S EIENS=ERXIEN_","
S FN=$$UP^XLFSTR($G(@GL@("Name",0,"FirstName",0)))
S LN=$$UP^XLFSTR($G(@GL@("Name",0,"LastName",0))) Q:'$L(LN)
S MN=$$UP^XLFSTR($G(@GL@("Name",0,"MiddleName",0)))
S FULLNM=LN_","_FN_$S(MN]"":" "_MN,1:"")
S SUFF=$$UP^XLFSTR($G(@GL@("Name",0,"Suffix",0)))
S PREF=$$UP^XLFSTR($G(@GL@("Name",0,"Prefix",0)))
S AL1=$G(@GL@("Address",0,"AddressLine1",0))
S AL2=$G(@GL@("Address",0,"AddressLine2",0))
S CITY=$G(@GL@("Address",0,"City",0))
S STATE=$G(@GL@("Address",0,"State",0))
S ZIP=$G(@GL@("Address",0,"ZipCode",0))
S SIEN=$$STRES(ZIP,STATE)
S SPEC=$G(@GL@("Specialty",0))
S PNPI=$G(@GL@("Identification",0,"NPI",0))
S PDEA=$G(@GL@("Identification",0,"DEANumber",0))
S STLIC=$G(@GL@("Identification",0,"StateLicenseNumber",0))
S PRVIEN=$$FINDPRE^PSOERXU2(FULLNM,$G(PNPI),$G(PDEA)) I PRVIEN S NEW=0
I 'PRVIEN S NEW=1,PRVIEN="+1"
S PRVIENS=PRVIEN_","
S FDA(F,PRVIENS,.01)=FULLNM,FDA(F,PRVIENS,.02)=LN,FDA(F,PRVIENS,.03)=FN,FDA(F,PRVIENS,.04)=MN,FDA(F,PRVIENS,.05)=SUFF
S FDA(F,PRVIENS,.06)=PREF,FDA(F,PRVIENS,4.1)=AL1,FDA(F,PRVIENS,4.2)=AL2,FDA(F,PRVIENS,4.3)=CITY
; STATE AND POINTER RESOLUTION
S FDA(F,PRVIENS,4.4)=SIEN,FDA(F,PRVIENS,4.5)=ZIP
S FDA(F,PRVIENS,1.2)=SPEC
S FDA(F,PRVIENS,1.1)="S"
I 'NEW D Q
.D FILE^DIE(,"FDA") K FDA
.D PRVCI(PRVIEN)
.S FDA(52.49,EIENS,2.6)=PRVIEN D FILE^DIE(,"FDA") K FDA
D UPDATE^DIE(,"FDA","NEWIEN") K FDA
S NPIEN=$O(NEWIEN(0)),NPIEN=$G(NEWIEN(NPIEN))
D PRVCI(NPIEN)
S FDA(52.49,EIENS,2.6)=NPIEN D FILE^DIE(,"FDA") K FDA
Q
STRES(ZIP,STATE) ;
N ZIPRES,SIEN
S SIEN=""
D POSTAL^XIPUTIL($E(ZIP,1,5),.ZIPRES) I $G(ZIPRES("STATE POINTER"))>0 S SIEN=$G(ZIPRES("STATE POINTER"))
I 'SIEN,STATE]"" S SIEN=$$FIND1^DIC(5,,,STATE,"C")
I 'SIEN,STATE]"" S SIEN=$O(^DIC(5,"C",STATE,0))
Q SIEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXA2 12114 printed Dec 13, 2024@02:28:21 Page 2
PSOERXA2 ;ALB/BWF - eRx Utilities/RPC's ; 8/3/2016 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**467,520,508**;DEC 1997;Build 295
+2 ;
+3 QUIT
+4 ;/BLB/ PSO*7.0*520 - BEGIN CHANGE ( ADD BOTH THE 'FAC' AND 'FIC' LINETAG TO YOUR ROUTINE )
FAC(ERXIEN) ; facility
+1 NEW GL,IDTYPE,IDVAL,F,FIEN,IENS,FNAME,FACFDA,AL1,AL2,CITY,STATE,ZIP,PLQUAL,FACFDA,SIEN
+2 SET GL=$NAME(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,"NewRx",0,"Facility",0))
+3 SET F=52.49
SET FIEN=""
SET IENS=ERXIEN_","
+4 SET FNAME=$GET(@GL@("FacilityName",0))
+5 SET FACFDA(F,IENS,70.1)=FNAME
+6 SET AL1=$GET(@GL@("Address",0,"AddressLine1",0))
SET FACFDA(F,IENS,70.2)=AL1
+7 SET AL2=$GET(@GL@("Address",0,"AddressLine2",0))
SET FACFDA(F,IENS,70.3)=AL2
+8 SET CITY=$GET(@GL@("Address",0,"City",0))
SET FACFDA(F,IENS,70.4)=CITY
+9 SET STATE=$GET(@GL@("Address",0,"State",0))
+10 SET ZIP=$GET(@GL@("Address",0,"ZipCode",0))
SET FACFDA(F,IENS,70.6)=ZIP
+11 SET SIEN=$$STRES(ZIP,STATE)
+12 SET FACFDA(F,IENS,70.5)=SIEN
+13 SET PLQUAL=$GET(@GL@("Address",0,"PlaceLocationQualifier",0))
SET FACFDA(F,IENS,70.7)=PLQUAL
+14 ;D FIC($P(FIEN,","))
DO FILE^DIE(,"FACFDA","ERR")
KILL FACFDA
+15 DO FIC(ERXIEN)
+16 ; future enhancement - file ID types - requires modification to the current payer information subfile
+17 ; - THIS REQUIRES RESOLUTION OF THE PAYERID TYPE ISSUE ALONG WITH PRIOR AUTH VALUES, ETC.
+18 ;S IDTYPE="" F S IDTYPE=$O(@GL@("Identification",0,IDTYPE)) Q:IDTYPE="" D
+19 ;S IDVAL=$G(@GL@("Identification",0,IDTYPE,0))
+20 QUIT
FIC(IEN) ;
+1 NEW IDTYP,IDVAL,FDA,I,CCNT,FIEN,FACFDA,IDCNT,ERR
+2 if 'IEN
QUIT
+3 SET IENS=IEN_","
+4 SET IDCNT=0
+5 KILL ^PS(52.49,IEN,71)
+6 SET IDNM=""
FOR
SET IDNM=$ORDER(@GL@("Identification",0,IDNM))
if IDNM=""
QUIT
Begin DoDot:1
+7 SET IDVAL=$GET(@GL@("Identification",0,IDNM,0))
+8 IF IDNM="NCPDPID"
IF $GET(NCPDPID)']""
SET NCPDPID=$GET(IDVAL)
+9 SET IDARY(IDNM)=IDVAL
+10 SET IDFND=0
+11 SET SRCH=0
FOR
SET SRCH=$ORDER(^PS(52.49,IEN,71,SRCH))
if 'SRCH
QUIT
Begin DoDot:2
+12 IF $$GET1^DIQ(52.4971,SRCH_","_IEN_",",.01)=IDNM
Begin DoDot:3
+13 SET IDFND=1
+14 SET FACFDA(52.4971,SRCH_","_IEN_",",.02)=IDVAL
DO FILE^DIE(,"FACFDA","ERR")
KILL FACFDA
End DoDot:3
End DoDot:2
+15 if IDFND
QUIT
+16 SET FACFDA(52.4971,"+1,"_IEN_",",.01)=IDNM
+17 SET FACFDA(52.4971,"+1,"_IEN_",",.02)=IDVAL
+18 DO UPDATE^DIE(,"FACFDA")
KILL FACFDA
End DoDot:1
+19 ; clear out existing communication Numbers
+20 KILL ^PS(52.49,IEN,72)
+21 SET I=-1
FOR
SET I=$ORDER(@GL@("CommunicationNumbers",0,"Communication",I))
if I=""
QUIT
Begin DoDot:1
+22 SET CCNT=$GET(CCNT)+1
+23 SET COMVAL=$GET(@GL@("CommunicationNumbers",0,"Communication",I,"Number",0))
+24 SET COMTYP=$GET(@GL@("CommunicationNumbers",0,"Communication",I,"Qualifier",0))
+25 SET FACFDA(52.4972,"+"_CCNT_","_IEN_",",.01)=COMVAL
+26 SET FACFDA(52.4972,"+"_CCNT_","_IEN_",",.02)=COMTYP
End DoDot:1
+27 DO UPDATE^DIE(,"FACFDA")
KILL FACFDA
+28 QUIT
+29 ;/BLB/ PSO*7.0*520 - END CHANGE
PHR(ERXIEN,MTYPE) ; pharamcy
+1 NEW GL,SNAME,AL1,AL2,CIT,STATE,ZIP,PLQUAL,COMTYP,COMVAL,I,F,EIENS,PHIEN,CCNT,NEW,SPEC,FDA,NEWPHIEN,GL2,FQUAL,FROM,SIEN
+2 NEW NCPDPID
+3 SET GL=$NAME(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,MTYPE,0,"Pharmacy",0))
+4 SET GL2=$NAME(^TMP($JOB,"PSOERXO1","Message","A","Qualifier","Header","A","Qualifier"))
+5 SET FQUAL=$GET(@GL2@("From","A","Qualifier"))
+6 SET FROM=$GET(@GL@("From",0))
+7 IF FQUAL="P"
IF FROM]""
SET NCPDPID=FROM
+8 SET F=52.47
SET PHIEN=""
+9 SET EIENS=ERXIEN_","
+10 SET SNAME=$GET(@GL@("StoreName",0))
+11 if '$LENGTH(SNAME)
QUIT
+12 IF $DATA(^PS(52.47,"B",SNAME))
SET PHIEN=$ORDER(^PS(52.47,"B",SNAME,0))
IF PHIEN
SET PHIEN=PHIEN_","
SET NEW=0
+13 ; if we found a match, clear out the existing communication numbers and identification
+14 IF PHIEN
KILL ^PS(52.47,$PIECE(PHIEN,","),3),^PS(52.47,$PIECE(PHIEN,","),2)
+15 IF '$GET(PHIEN)
SET PHIEN="+1,"
SET NEW=1
SET FDA(F,PHIEN,.01)=SNAME
+16 SET FDA(F,PHIEN,.05)=SNAME
+17 SET SPEC=$GET(@GL@("Specialty",0))
SET FDA(F,PHIEN,1.8)=SPEC
+18 SET AL1=$GET(@GL@("Address",0,"AddressLine1",0))
SET FDA(F,PHIEN,1.1)=AL1
+19 SET AL2=$GET(@GL@("Address",0,"AddressLine2",0))
SET FDA(F,PHIEN,1.2)=AL2
+20 SET CITY=$GET(@GL@("Address",0,"City",0))
SET FDA(F,PHIEN,1.3)=CITY
+21 SET STATE=$GET(@GL@("Address",0,"State",0))
+22 SET ZIP=$GET(@GL@("Address",0,"ZipCode",0))
SET FDA(F,PHIEN,1.5)=ZIP
+23 SET SIEN=$$STRES(ZIP,STATE)
+24 SET FDA(F,PHIEN,1.4)=SIEN
+25 SET PLQUAL=$GET(@GL@("Address",0,"PlaceLocationQualifier",0))
SET FDA(F,PHIEN,1.7)=PLQUAL
+26 ; if this is an existing pharmacy entry, file the updates, communication values, and identification, then link to 52.49
+27 IF 'NEW
Begin DoDot:1
+28 DO FILE^DIE(,"FDA")
KILL FDA
DO PHRIC($PIECE(PHIEN,","))
+29 SET FDA(52.49,EIENS,2.5)=$PIECE(PHIEN,",")
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:1
QUIT
+30 ; for a new entry, file the entry, then file communication/identification and link to 52.49
+31 DO UPDATE^DIE(,"FDA","NEWPHIEN")
KILL FDA
+32 SET PHIEN=$ORDER(NEWPHIEN(0))
SET PHIEN=$GET(NEWPHIEN(PHIEN))
+33 if 'PHIEN
QUIT
+34 DO PHRIC(PHIEN)
+35 SET FDA(52.49,EIENS,2.5)=PHIEN
DO FILE^DIE(,"FDA")
KILL FDA
+36 QUIT
PHRIC(IEN) ; pharmacy identification and communication information
+1 NEW IDTYP,IDVAL,FDA,I,CCNT,PHIEN,FDA,IDCNT
+2 if 'IEN
QUIT
+3 SET PHIEN=IEN_","
+4 SET IDCNT=0
+5 KILL ^PS(52.47,IEN,2)
+6 SET IDNM=""
FOR
SET IDNM=$ORDER(@GL@("Identification",0,IDNM))
if IDNM=""
QUIT
Begin DoDot:1
+7 SET IDVAL=$GET(@GL@("Identification",0,IDNM,0))
+8 IF IDNM="NCPDPID"
IF $GET(NCPDPID)']""
SET NCPDPID=$GET(IDVAL)
+9 SET IDARY(IDNM)=IDVAL
+10 SET IDFND=0
+11 SET SRCH=0
FOR
SET SRCH=$ORDER(^PS(52.47,IEN,2,SRCH))
if 'SRCH
QUIT
Begin DoDot:2
+12 IF $$GET1^DIQ(52.472,SRCH_","_IEN_",",.01)=IDNM
Begin DoDot:3
+13 SET IDFND=1
+14 SET FDA(52.472,SRCH_","_IEN_",",.02)=IDVAL
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:3
End DoDot:2
+15 if IDFND
QUIT
+16 SET FDA(52.472,"+1,"_IEN_",",.01)=IDNM
+17 SET FDA(52.472,"+1,"_IEN_",",.02)=IDVAL
+18 DO UPDATE^DIE(,"FDA")
KILL FDA
End DoDot:1
+19 IF $GET(NCPDPID)]""
SET FDA(52.47,PHIEN,.02)=NCPDPID
DO FILE^DIE(,"FDA")
KILL FDA
+20 ; clear out existing communication Numbers
+21 KILL ^PS(52.47,IEN,3)
+22 SET I=-1
FOR
SET I=$ORDER(@GL@("CommunicationNumbers",0,"Communication",I))
if I=""
QUIT
Begin DoDot:1
+23 SET CCNT=$GET(CCNT)+1
+24 SET COMVAL=$GET(@GL@("CommunicationNumbers",0,"Communication",I,"Number",0))
+25 SET COMTYP=$GET(@GL@("CommunicationNumbers",0,"Communication",I,"Qualifier",0))
+26 SET FDA(52.473,"+"_CCNT_","_PHIEN,.01)=COMVAL
+27 SET FDA(52.473,"+"_CCNT_","_PHIEN,.02)=COMTYP
End DoDot:1
+28 DO UPDATE^DIE(,"FDA")
KILL FDA
+29 QUIT
PRE(ERXIEN,MTYPE) ; prescriber
+1 NEW GL,FN,LN,MN,SUFF,PREF,AL1,AL2,CITY,STATE,ZIP,IDDONE,I,IDNM,IDVAL,C,CQUAL,CVAL,SPEC,AFN,ALN,AMN,APREF,ASUFF,FULLNM
+2 NEW EIENS,FDA,NPIEN,NEW,PRVIEN,PRVIENS,NEWIEN,IDFND,SRCH,PNPI,PDEA,GL2,FQUAL,FROM,SIEN
+3 SET GL=$NAME(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,MTYPE,0,"Prescriber",0))
+4 SET GL2=$NAME(^TMP($JOB,"PSOERXO1","Message","A","Qualifier","Header","A","Qualifier"))
+5 SET FQUAL=$GET(@GL2@("From","A","Qualifier"))
+6 SET FROM=$GET(@GL@("From",0))
+7 IF FQUAL="D"
IF FROM]""
SET PNPI=FROM
+8 SET F=52.48
+9 SET EIENS=ERXIEN_","
+10 SET FN=$$UP^XLFSTR($GET(@GL@("Name",0,"FirstName",0)))
+11 SET LN=$$UP^XLFSTR($GET(@GL@("Name",0,"LastName",0)))
+12 SET MN=$$UP^XLFSTR($GET(@GL@("Name",0,"MiddleName",0)))
+13 SET FULLNM=LN_","_FN_$SELECT(MN]"":" "_MN,1:"")
+14 SET SUFF=$$UP^XLFSTR($GET(@GL@("Name",0,"Suffix",0)))
+15 SET PREF=$$UP^XLFSTR($GET(@GL@("Name",0,"Prefix",0)))
+16 SET AL1=$GET(@GL@("Address",0,"AddressLine1",0))
+17 SET AL2=$GET(@GL@("Address",0,"AddressLine2",0))
+18 SET CITY=$GET(@GL@("Address",0,"City",0))
+19 SET STATE=$GET(@GL@("Address",0,"State",0))
+20 SET ZIP=$GET(@GL@("Address",0,"ZipCode",0))
+21 SET SIEN=$$STRES(ZIP,STATE)
+22 SET SPEC=$GET(@GL@("Specialty",0))
+23 SET AFN=$$UP^XLFSTR($GET(@GL@("PrescriberAgent",0,"FirstName",0)))
+24 SET ALN=$$UP^XLFSTR($GET(@GL@("PrescriberAgent",0,"LastName",0)))
+25 SET AMN=$$UP^XLFSTR($GET(@GL@("PrescriberAgent",0,"MiddleName",0)))
+26 SET APREF=$$UP^XLFSTR($GET(@GL@("PrescriberAgent",0,"Prefix",0)))
+27 SET ASUFF=$$UP^XLFSTR($GET(@GL@("PrescriberAgent",0,"Suffix",0)))
+28 ; try to match the provider/supervisor. if no match, create a new entry for this provider
+29 ; if there is no NPI, grab it from the Identification multiple.
+30 IF '$GET(PNPI)
SET PNPI=$GET(@GL@("Identification",0,"NPI",0))
+31 SET PDEA=$GET(@GL@("Identification",0,"DEANumber",0))
+32 SET STLIC=$GET(@GL@("Identification",0,"StateLicenseNumber",0))
+33 SET PRVIEN=$$FINDPRE^PSOERXU2(FULLNM,$GET(PNPI),PDEA)
IF PRVIEN
SET NEW=0
+34 IF 'PRVIEN
SET NEW=1
SET PRVIEN="+1"
+35 SET PRVIENS=PRVIEN_","
+36 SET FDA(F,PRVIENS,.01)=FULLNM
SET FDA(F,PRVIENS,.02)=LN
SET FDA(F,PRVIENS,.03)=FN
SET FDA(F,PRVIENS,.04)=MN
SET FDA(F,PRVIENS,.05)=SUFF
+37 SET FDA(F,PRVIENS,.06)=PREF
SET FDA(F,PRVIENS,4.1)=AL1
SET FDA(F,PRVIENS,4.2)=AL2
SET FDA(F,PRVIENS,4.3)=CITY
+38 SET FDA(F,PRVIENS,4.4)=SIEN
SET FDA(F,PRVIENS,4.5)=ZIP
+39 SET FDA(F,PRVIENS,5.1)=ALN
SET FDA(F,PRVIENS,5.2)=AFN
SET FDA(F,PRVIENS,5.3)=AMN
SET FDA(F,PRVIENS,5.4)=ASUFF
SET FDA(F,PRVIENS,5.5)=APREF
+40 SET FDA(F,PRVIENS,1.2)=SPEC
+41 SET FDA(F,PRVIENS,1.8)=$GET(STLIC)
+42 SET FDA(F,PRVIENS,1.1)="PR"
+43 IF 'NEW
Begin DoDot:1
+44 DO FILE^DIE(,"FDA")
+45 DO PRVCI(PRVIEN)
+46 SET FDA(52.49,EIENS,2.1)=PRVIEN
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:1
QUIT
+47 DO UPDATE^DIE(,"FDA","NEWIEN")
KILL FDA
+48 SET NPIEN=$ORDER(NEWIEN(0))
SET NPIEN=$GET(NEWIEN(NPIEN))
+49 DO PRVCI(NPIEN)
+50 SET FDA(52.49,EIENS,2.1)=NPIEN
DO FILE^DIE(,"FDA")
KILL FDA
+51 QUIT
PRVCI(IEN) ;
+1 NEW IENS,C,CQUAL,CVAL,FDA,IDNM,IDVAL,IDARY,IDFND,SRCH,NCPDPID,PHIN,DEA,STLIC,PNPI
+2 SET IENS=IEN_","
+3 ; kill off existing data
+4 KILL ^PS(52.48,IEN,3)
+5 SET C=-1
FOR
SET C=$ORDER(@GL@("CommunicationNumbers",0,"Communication",C))
if C=""
QUIT
Begin DoDot:1
+6 SET CQUAL=$GET(@GL@("CommunicationNumbers",0,"Communication",C,"Qualifier",0))
+7 SET CVAL=$GET(@GL@("CommunicationNumbers",0,"Communication",C,"Number",0))
+8 SET FDA(52.483,"+1,"_IENS,.01)=CVAL
+9 SET FDA(52.483,"+1,"_IENS,.02)=CQUAL
+10 DO UPDATE^DIE(,"FDA")
KILL FDA
End DoDot:1
+11 ; kill existing Identification data.
+12 KILL ^PS(52.48,IEN,6)
+13 SET IDNM=""
FOR
SET IDNM=$ORDER(@GL@("Identification",0,IDNM))
if IDNM=""
QUIT
Begin DoDot:1
+14 SET IDVAL=$GET(@GL@("Identification",0,IDNM,0))
+15 SET IDARY(IDNM)=IDVAL
+16 IF IDNM="NCPDPID"
SET NCPDPID=IDVAL
+17 IF IDNM="HIN"
SET PHIN=IDVAL
+18 IF IDNM="DEANumber"
SET DEA=IDVAL
+19 IF IDNM="StateLicenseNumber"
SET STLIC=IDVAL
+20 IF IDNM="NPI"
SET PNPI=IDVAL
+21 SET IDFND=0
+22 SET SRCH=0
FOR
SET SRCH=$ORDER(^PS(52.48,IEN,6,SRCH))
if 'SRCH
QUIT
Begin DoDot:2
+23 IF $$GET1^DIQ(52.486,SRCH_","_IEN_",",.01)=IDNM
Begin DoDot:3
+24 SET IDFND=1
+25 SET FDA(52.486,SRCH_","_IEN_",",.02)=IDVAL
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:3
End DoDot:2
+26 if IDFND
QUIT
+27 SET FDA(52.486,"+1,"_IEN_",",.01)=IDNM
+28 SET FDA(52.486,"+1,"_IEN_",",.02)=IDVAL
+29 DO UPDATE^DIE(,"FDA")
KILL FDA
End DoDot:1
+30 SET FDA(52.48,IENS,1.4)=$GET(NCPDPID)
SET FDA(52.48,IENS,1.5)=$GET(PNPI)
SET FDA(52.48,IENS,1.6)=$GET(DEA)
SET FDA(52.48,IENS,1.7)=$GET(PHIN)
+31 DO FILE^DIE(,"FDA")
KILL FDA
+32 QUIT
REQ ; request
+1 NEW GL,CRTYPE,RETREC,RRNUM
+2 SET GL=$NAME(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,"NewRx",0,"Request",0))
+3 SET CRTYPE=$GET(@GL@("ChangeRequestType",0))
+4 SET RETREC=$GET(@GL@("ReturnReceipt",0))
+5 SET RRNUM=$GET(@GL@("RequestReferenceNumber",0))
+6 ; FUTURE ENHANCEMENT - file this information when we are getting other request types.
+7 QUIT
SUP(ERXIEN,MTYPE) ; supervisor
+1 NEW GL,FN,LN,MN,SUFF,PREF,AL1,AL2,CITY,STATE,ZIP,IDDONE,I,IDNM,IDVAL,C,CQUAL,CVAL,SPEC,AFN,ALN,AMN,APREF,ASUFF,EIENS
+2 NEW FDA,NPIEN,NEW,PRVIEN,PRVIENS,NEWIEN,FDA,IDFND,SRCH,PNPI,PDEA,STLIC,SIEN
+3 SET GL=$NAME(^TMP($JOB,"PSOERXO1","Message",0,"Body",0,MTYPE,0,"Supervisor",0))
+4 SET EIENS=ERXIEN_","
+5 SET FN=$$UP^XLFSTR($GET(@GL@("Name",0,"FirstName",0)))
+6 SET LN=$$UP^XLFSTR($GET(@GL@("Name",0,"LastName",0)))
if '$LENGTH(LN)
QUIT
+7 SET MN=$$UP^XLFSTR($GET(@GL@("Name",0,"MiddleName",0)))
+8 SET FULLNM=LN_","_FN_$SELECT(MN]"":" "_MN,1:"")
+9 SET SUFF=$$UP^XLFSTR($GET(@GL@("Name",0,"Suffix",0)))
+10 SET PREF=$$UP^XLFSTR($GET(@GL@("Name",0,"Prefix",0)))
+11 SET AL1=$GET(@GL@("Address",0,"AddressLine1",0))
+12 SET AL2=$GET(@GL@("Address",0,"AddressLine2",0))
+13 SET CITY=$GET(@GL@("Address",0,"City",0))
+14 SET STATE=$GET(@GL@("Address",0,"State",0))
+15 SET ZIP=$GET(@GL@("Address",0,"ZipCode",0))
+16 SET SIEN=$$STRES(ZIP,STATE)
+17 SET SPEC=$GET(@GL@("Specialty",0))
+18 SET PNPI=$GET(@GL@("Identification",0,"NPI",0))
+19 SET PDEA=$GET(@GL@("Identification",0,"DEANumber",0))
+20 SET STLIC=$GET(@GL@("Identification",0,"StateLicenseNumber",0))
+21 SET PRVIEN=$$FINDPRE^PSOERXU2(FULLNM,$GET(PNPI),$GET(PDEA))
IF PRVIEN
SET NEW=0
+22 IF 'PRVIEN
SET NEW=1
SET PRVIEN="+1"
+23 SET PRVIENS=PRVIEN_","
+24 SET FDA(F,PRVIENS,.01)=FULLNM
SET FDA(F,PRVIENS,.02)=LN
SET FDA(F,PRVIENS,.03)=FN
SET FDA(F,PRVIENS,.04)=MN
SET FDA(F,PRVIENS,.05)=SUFF
+25 SET FDA(F,PRVIENS,.06)=PREF
SET FDA(F,PRVIENS,4.1)=AL1
SET FDA(F,PRVIENS,4.2)=AL2
SET FDA(F,PRVIENS,4.3)=CITY
+26 ; STATE AND POINTER RESOLUTION
+27 SET FDA(F,PRVIENS,4.4)=SIEN
SET FDA(F,PRVIENS,4.5)=ZIP
+28 SET FDA(F,PRVIENS,1.2)=SPEC
+29 SET FDA(F,PRVIENS,1.1)="S"
+30 IF 'NEW
Begin DoDot:1
+31 DO FILE^DIE(,"FDA")
KILL FDA
+32 DO PRVCI(PRVIEN)
+33 SET FDA(52.49,EIENS,2.6)=PRVIEN
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:1
QUIT
+34 DO UPDATE^DIE(,"FDA","NEWIEN")
KILL FDA
+35 SET NPIEN=$ORDER(NEWIEN(0))
SET NPIEN=$GET(NEWIEN(NPIEN))
+36 DO PRVCI(NPIEN)
+37 SET FDA(52.49,EIENS,2.6)=NPIEN
DO FILE^DIE(,"FDA")
KILL FDA
+38 QUIT
STRES(ZIP,STATE) ;
+1 NEW ZIPRES,SIEN
+2 SET SIEN=""
+3 DO POSTAL^XIPUTIL($EXTRACT(ZIP,1,5),.ZIPRES)
IF $GET(ZIPRES("STATE POINTER"))>0
SET SIEN=$GET(ZIPRES("STATE POINTER"))
+4 IF 'SIEN
IF STATE]""
SET SIEN=$$FIND1^DIC(5,,,STATE,"C")
+5 IF 'SIEN
IF STATE]""
SET SIEN=$ORDER(^DIC(5,"C",STATE,0))
+6 QUIT SIEN
