APSPES9 ;IHS/MSC/PLS - Master File SPI Request;27-Aug-2013 23:15;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1008,1009,1010,1013,1014,1016**;Sep 23, 2004;Build 74
; Modified - IHS/MSC/PLS - 03/24/2011 - EN+20 (removed checks for DEA)
; 09/14/2011 - Added support for service level
; 01/29/2013 - Uncomment lines related to service level
Q
ADDPRV(PVD,MFNTYP) ;
Q:'$G(PVD)
N HLPM,HLST,ERR,ARY,AP,WHO,ERR
S HLPM("MESSAGE TYPE")="MFN"
S HLPM("EVENT")="M02"
S HLPM("VERSION")=2.5
I '$$NEWMSG^HLOAPI(.HLPM,.HLST,.ERR) W !,EHR,0
S HLFS=HLPM("FIELD SEPARATOR")
S HLECH=HLPM("ENCODING CHARACTERS")
S HL1("ECH")=HLECH
S HL1("FS")=HLFS
S HL1("Q")=""
S HL1("VER")=HLPM("VERSION")
S MFNTYP=$$FNDTYP(PVD)
D MFI
D MFE
;D STF
;D ORG
;D PRA
S AP("SENDING APPLICATION")="APSP RPMS"
S AP("ACCEPT ACK TYPE")="AL" ; Commit ACK
S AP("APP ACK TYPE")="AL"
S AP("QUEUE")="RPMS SPI"
S AP("FAILURE RESPONSE")="FAILURE^APSPES9"
S WHO("RECEIVING APPLICATION")="SURESCRIPTS"
S WHO("FACILITY LINK NAME")="APSP EPRES"
I '$$SENDONE^HLOAPI1(.HLST,.AP,.WHO,.ERR) W !,ERR
Q
;
MFI ;EP
N MFI,SLC
S SLC=(NEWRX*1)+(REFRX*2) ;Service Level code
D SET(.ARY,"MFI",0)
D SET(.ARY,"STF",1) ; Master File Identifier
D SET(.ARY,SLC,1,4)
D SET(.ARY,"UPD",3) ; Update record
D SET(.ARY,$$HLDATE^HLFNC($$NOW^XLFDT()),4) ; Entered Date/Time
D SET(.ARY,"MF",6) ; Response level code
S MFI=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
MFE ;EP
N MFE,PKV
S PKV=PVD_":"_DUZ(2)_":1"
D SET(.ARY,"MFE",0)
D SET(.ARY,MFNTYP,1) ; Record-level event code
D SET(.ARY,PKV,2) ; MFN Control ID - DUZ.DUZ(2).1
D SET(.ARY,PKV,4) ; Primary Key Value
S MFE=$$ADDSEG^HLOAPI(.HLST,.ARY)
I MFE D
.D STF(PKV)
.D PRA(PKV)
.D ORG
Q
STF(PKV) ;EP
N STF,NM,LP,VAL,PHONE,FAX
S NM=$$HLNAME^HLFNC($$GET1^DIQ(200,+PKV,.01))
D SET(.ARY,"STF",0)
D SET(.ARY,PKV,1) ; Primary Key value
D SET(.ARY,"NEW PERSON",1,3) ; Coding System - File Name
D SET(.ARY,+PKV,2) ; Staff ID (DUZ)
F LP=1:1:$L(NM,$E(HLECH)) S VAL=$P(NM,$E(HLECH),LP) D
.D SET(.ARY,VAL,3,LP)
D SET(.ARY,"A",7) ; Active/Inactive Flag
S PHONE=$$GET1^DIQ(200,+PKV,.132)
S:'$L(PHONE) PHONE=$$GET1^DIQ(9999999.06,DUZ(2),.13) ; Default to Location phone
D SET(.ARY,$$HLPHONE^HLFNC(PHONE),10,1) ; Work Phone
D SET(.ARY,"WPH",10,2)
D SET(.ARY,"PH",10,3)
S FAX=$$GET1^DIQ(200,+PKV,.136)
D SET(.ARY,$$HLPHONE^HLFNC(FAX),10,1,,2) ; Fax
D SET(.ARY,"WPN",10,2,,2)
D SET(.ARY,"FX",10,3,,2)
D SET(.ARY,$$GET1^DIQ(200,+PKV,.151),10,4) ; email address
D SET(.ARY,$$GET1^DIQ(4,DUZ(2),1.01),11,1) ; Institution Address 1
D SET(.ARY,$$GET1^DIQ(4,DUZ(2),1.02),11,2) ; Institution Address 2
D SET(.ARY,$$GET1^DIQ(4,DUZ(2),1.03),11,3) ; Institution City
D SET(.ARY,$$GET1^DIQ(5,$$GET1^DIQ(4,DUZ(2),.02,"I"),1),11,4) ; Institution State Abbreviation
D SET(.ARY,$E($$GET1^DIQ(4,DUZ(2),1.04,"I"),1,5),11,5) ; Institution 5 digit Zip Code
D SET(.ARY,"O",11,7) ; Address Type
D SET(.ARY,"O",16) ; Preferred method of contact
D SET(.ARY,$$GET1^DIQ(200,+PKV,8),18) ; Job Title
D SET(.ARY,$$GET1^DIQ(200,+PKV,53.5,"I"),19,1) ; Job Code/Class
D SET(.ARY,$$GET1^DIQ(200,+PKV,53.5),19,2)
S STF=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
ORG ;EP
Q
PRA(PKV) ;EP
N PRA,NM,LP,VAL,DEA,NPI
S DEA=$$PRVDEA(PKV)
;S DEA=$$GET1^DIQ(200,+PKV,53.2) ; New Person DEA#
S NPI=$$GET1^DIQ(200,+PKV,41.99) ; New Person NPI
I '$L(DEA) D
.S DEA=$$GET1^DIQ(4,DUZ(2),52) ; Institution DEA
.S DEA=DEA_"-"_NPI ;$$GET1^DIQ(9999999.06,DUZ(2),.12) ;CHANGED TO USE NPI INSTEAD OF ASUFAC CODE
D SET(.ARY,"PRA",0)
D SET(.ARY,PKV,1) ; Primary Key value
D SET(.ARY,DEA,6,1,1,1)
D SET(.ARY,"DEA",6,2,,1)
D SET(.ARY,NPI,6,1,,2)
D SET(.ARY,"NPI",6,2,,2)
S PRA=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
SET(ARY,V,F,C,S,R) ;EP
D SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
Q
; Failed Transmission Callback
FAILURE ; EP
N ARY,SEGIEN
D PARSE^APSPES2(.DATA,HLMSGIEN,.HLMSTATE)
S SEGIEN=$$FSEGIEN^APSPES1(.DATA,"MFN")
Q:'SEGIEN
D NOTIF($$GET1^DIQ(200,+PKV,.01)_": Unable to transmit SPI request.")
Q
; Process MFK acknowledgement
MFK ; EP -
N ARY,SEGIEN,SEGDAT,PVD,PKV,SPI,SLC
D PARSE^APSPES2(.DATA,HLMSGIEN,.HLMSTATE)
S SEGIEN=$$FSEGIEN^APSPES1(.DATA,"MFA")
Q:'SEGIEN
M SEGDAT=DATA(SEGIEN)
S PKV=$$GET^HLOPRS(.SEGDAT,2)
I $$GET^HLOPRS(.SEGDAT,4)'="S" D
.S SEGIEN=$$FSEGIEN^APSPES1(.DATA,"ERR")
.I SEGIEN D
..M SEGDAT=DATA(SEGIEN)
..S ERR=$$GET^HLOPRS(.SEGDAT,8)
..D:$L(ERR) NOTIF($$GET1^DIQ(200,+PKV,.01)_": "_$P(ERR,":"))
E D
.S SEGIEN=$$FSEGIEN^APSPES1(.DATA,"MFI")
.Q:'SEGIEN
.M SEGDAT=DATA(SEGIEN)
.S SPI=$$GET^HLOPRS(.SEGDAT,1)
.S SLC=$$GET^HLOPRS(.SEGDAT,1,4) ;Service Level code
.D NOTIF($$GET1^DIQ(200,+PKV,.01)_": Please assign SPI "_SPI_" (SL:"_SLC_") to user.")
Q
; Notify SPI mail group
NOTIF(MSG) ; EP -
N RET
S XQAMSG=MSG
S XQA("G.SPI NOTIFICATION")=""
D SETUP^XQALERT
Q
; Main entry point for selection of user
EN ; EP -
N USR,APSPPOP,NEWRX,REFRX
W @IOF
W !,"Surescripts Provider ID Request Utility",!
S USR=$$GETIEN1^APSPUTIL(200,"Select Provider: ",-1,,"I $S('$D(^VA(200,Y,0)):0,Y<1:1,$L($P(^(0),U,3)):1,1:0),$P($G(^VA(200,Y,""PS"")),U)")
Q:USR<1
S (NEWRX,REFRX)=0
W !!,"Processing request for: "_$$GET1^DIQ(200,+USR,.01)
; Check for active user
I '$$ACTIVE^XUSER(+USR) D Q
.W !,"User is not an active RPMS user.",!
.D DIRZ
; Check for existing SPI
I $$SPI^APSPES1(+USR) D Q
.W !,"User has already been assigned an SPI number.",!
.D DIRZ
; Ensure that selected user has an NPI
I '$$GET1^DIQ(200,+USR,41.99) D Q
.W !,"The selected user must have an NPI assigned.",!
.D DIRZ
; If needed, indicate that Institutional DEA will be used.
;I '$L($$GET1^DIQ(200,+USR,53.2)) D
;.W !,"This provider lacks an individual DEA number."
;.W !,"The facility DEA number will be used to request the SPI number."
;.D DIRZ
;I '$L($$GET1^DIQ(4,DUZ(2),52)) D Q
;.W !,"The selected facility, "_$$GET1^DIQ(4,DUZ(2),.01)_" lacks a Facility DEA number."
;.W !,"This will need to be corrected before you can continue with the request."
;.D DIRZ
I '$L($$GET1^DIQ(200,+USR,.136)) D Q
.W !,"The user lacks a fax number. This will need to be corrected before you can"
.W !,"continue with the request."
.D DIRZ
I '$L($$GET1^DIQ(200,+USR,.151)) D Q
.W !,"The user lacks an email address. This will need to be corrected before you can"
.W !,"continue with the request."
.D DIRZ
I '$L($$GET1^DIQ(9999999.06,DUZ(2),.13)) D Q
.W !,"The selected facility, "_$$GET1^DIQ(4,DUZ(2),.01)_" lacks a phone number."
.W !,"This will need to be corrected before you can continue with the request."
.D DIRZ
;IHS/MSC/PLS - 05/24/2012
I $$DIRYN^APSPUTIL("Will provider be writing New prescriptions electronically","YES",,.APSPPOP) D
.S NEWRX=1
;I $$DIRYN^APSPUTIL("Will provider be taking Refill Requests electronically","NO",,.APSPPOP) D
I $$DIR^APSPUTIL("SA^0:NO","Will provider be taking Refill Requests electronically? ","No")
.S REFRX=1
I $$DIRYN^APSPUTIL("Request SPI","YES",,.APSPPOP) D
.D ADDPRV(USR,"MAD")
.W !!,"An SPI number has been requested. A Kernel Alert will be sent to"
.W !,"the SPI NOTIFICATION group when the SPI number is received."
Q
;
DIRZ ;EP - Prompt to continue
D DIRZ^APSPUTIL("Press ENTER to continue")
Q
;
FNDTYP(IEN) ;EP - Determine if a new or update message should be sent
;If MFNTYP exists, no need to do the lookup
Q:$D(MFNTYP) MFNTYP
N TD,ENTER,ACTIVE,RES
S TD=$$DT^XLFDT()
S ENTER=$P($G(^VA(200,IEN,1)),U,7) ; Date Entered
I TD>ENTER S RES="MUP1"
I ENTER=TD D
.I $P($G(^VA(200,IEN,1.1)),U,1)'="" S RES="MUP1"
.I $P($G(^VA(200,IEN,1.1)),U,1)="" S RES="MAD"
I $P($G(^VA(200,IEN,0)),U,11)!($P($G(^VA(200,IEN,"PS")),U,4)) S RES="MDC"
Q RES
;
ADDPTL(PVD) ;EP - Entry point for APSP ERX MFN UPDATE protocol
;Additional business rules to be added here
D ADDPRV(PVD)
Q
PRVDEA(PKV) ;EP-
N DEA,NPI
S DEA=$$GET1^DIQ(200,+PKV,53.2) ; New Person DEA#
S NPI=$$GET1^DIQ(200,+PKV,41.99) ; New Person NPI
I '$L(DEA) D
.S DEA=$$GET1^DIQ(4,DUZ(2),52) ; Institution DEA
.S DEA=DEA_"-"_NPI
Q DEA
APSPES9 ;IHS/MSC/PLS - Master File SPI Request;27-Aug-2013 23:15;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1008,1009,1010,1013,1014,1016**;Sep 23, 2004;Build 74
+2 ; Modified - IHS/MSC/PLS - 03/24/2011 - EN+20 (removed checks for DEA)
+3 ; 09/14/2011 - Added support for service level
+4 ; 01/29/2013 - Uncomment lines related to service level
+5 QUIT
ADDPRV(PVD,MFNTYP) ;
+1 IF '$GET(PVD)
QUIT
+2 NEW HLPM,HLST,ERR,ARY,AP,WHO,ERR
+3 SET HLPM("MESSAGE TYPE")="MFN"
+4 SET HLPM("EVENT")="M02"
+5 SET HLPM("VERSION")=2.5
+6 IF '$$NEWMSG^HLOAPI(.HLPM,.HLST,.ERR)
WRITE !,EHR,0
+7 SET HLFS=HLPM("FIELD SEPARATOR")
+8 SET HLECH=HLPM("ENCODING CHARACTERS")
+9 SET HL1("ECH")=HLECH
+10 SET HL1("FS")=HLFS
+11 SET HL1("Q")=""
+12 SET HL1("VER")=HLPM("VERSION")
+13 SET MFNTYP=$$FNDTYP(PVD)
+14 DO MFI
+15 DO MFE
+16 ;D STF
+17 ;D ORG
+18 ;D PRA
+19 SET AP("SENDING APPLICATION")="APSP RPMS"
+20 ; Commit ACK
SET AP("ACCEPT ACK TYPE")="AL"
+21 SET AP("APP ACK TYPE")="AL"
+22 SET AP("QUEUE")="RPMS SPI"
+23 SET AP("FAILURE RESPONSE")="FAILURE^APSPES9"
+24 SET WHO("RECEIVING APPLICATION")="SURESCRIPTS"
+25 SET WHO("FACILITY LINK NAME")="APSP EPRES"
+26 IF '$$SENDONE^HLOAPI1(.HLST,.AP,.WHO,.ERR)
WRITE !,ERR
+27 QUIT
+28 ;
MFI ;EP
+1 NEW MFI,SLC
+2 ;Service Level code
SET SLC=(NEWRX*1)+(REFRX*2)
+3 DO SET(.ARY,"MFI",0)
+4 ; Master File Identifier
DO SET(.ARY,"STF",1)
+5 DO SET(.ARY,SLC,1,4)
+6 ; Update record
DO SET(.ARY,"UPD",3)
+7 ; Entered Date/Time
DO SET(.ARY,$$HLDATE^HLFNC($$NOW^XLFDT()),4)
+8 ; Response level code
DO SET(.ARY,"MF",6)
+9 SET MFI=$$ADDSEG^HLOAPI(.HLST,.ARY)
+10 QUIT
MFE ;EP
+1 NEW MFE,PKV
+2 SET PKV=PVD_":"_DUZ(2)_":1"
+3 DO SET(.ARY,"MFE",0)
+4 ; Record-level event code
DO SET(.ARY,MFNTYP,1)
+5 ; MFN Control ID - DUZ.DUZ(2).1
DO SET(.ARY,PKV,2)
+6 ; Primary Key Value
DO SET(.ARY,PKV,4)
+7 SET MFE=$$ADDSEG^HLOAPI(.HLST,.ARY)
+8 IF MFE
Begin DoDot:1
+9 DO STF(PKV)
+10 DO PRA(PKV)
+11 DO ORG
End DoDot:1
+12 QUIT
STF(PKV) ;EP
+1 NEW STF,NM,LP,VAL,PHONE,FAX
+2 SET NM=$$HLNAME^HLFNC($$GET1^DIQ(200,+PKV,.01))
+3 DO SET(.ARY,"STF",0)
+4 ; Primary Key value
DO SET(.ARY,PKV,1)
+5 ; Coding System - File Name
DO SET(.ARY,"NEW PERSON",1,3)
+6 ; Staff ID (DUZ)
DO SET(.ARY,+PKV,2)
+7 FOR LP=1:1:$LENGTH(NM,$EXTRACT(HLECH))
SET VAL=$PIECE(NM,$EXTRACT(HLECH),LP)
Begin DoDot:1
+8 DO SET(.ARY,VAL,3,LP)
End DoDot:1
+9 ; Active/Inactive Flag
DO SET(.ARY,"A",7)
+10 SET PHONE=$$GET1^DIQ(200,+PKV,.132)
+11 ; Default to Location phone
IF '$LENGTH(PHONE)
SET PHONE=$$GET1^DIQ(9999999.06,DUZ(2),.13)
+12 ; Work Phone
DO SET(.ARY,$$HLPHONE^HLFNC(PHONE),10,1)
+13 DO SET(.ARY,"WPH",10,2)
+14 DO SET(.ARY,"PH",10,3)
+15 SET FAX=$$GET1^DIQ(200,+PKV,.136)
+16 ; Fax
DO SET(.ARY,$$HLPHONE^HLFNC(FAX),10,1,,2)
+17 DO SET(.ARY,"WPN",10,2,,2)
+18 DO SET(.ARY,"FX",10,3,,2)
+19 ; email address
DO SET(.ARY,$$GET1^DIQ(200,+PKV,.151),10,4)
+20 ; Institution Address 1
DO SET(.ARY,$$GET1^DIQ(4,DUZ(2),1.01),11,1)
+21 ; Institution Address 2
DO SET(.ARY,$$GET1^DIQ(4,DUZ(2),1.02),11,2)
+22 ; Institution City
DO SET(.ARY,$$GET1^DIQ(4,DUZ(2),1.03),11,3)
+23 ; Institution State Abbreviation
DO SET(.ARY,$$GET1^DIQ(5,$$GET1^DIQ(4,DUZ(2),.02,"I"),1),11,4)
+24 ; Institution 5 digit Zip Code
DO SET(.ARY,$EXTRACT($$GET1^DIQ(4,DUZ(2),1.04,"I"),1,5),11,5)
+25 ; Address Type
DO SET(.ARY,"O",11,7)
+26 ; Preferred method of contact
DO SET(.ARY,"O",16)
+27 ; Job Title
DO SET(.ARY,$$GET1^DIQ(200,+PKV,8),18)
+28 ; Job Code/Class
DO SET(.ARY,$$GET1^DIQ(200,+PKV,53.5,"I"),19,1)
+29 DO SET(.ARY,$$GET1^DIQ(200,+PKV,53.5),19,2)
+30 SET STF=$$ADDSEG^HLOAPI(.HLST,.ARY)
+31 QUIT
ORG ;EP
+1 QUIT
PRA(PKV) ;EP
+1 NEW PRA,NM,LP,VAL,DEA,NPI
+2 SET DEA=$$PRVDEA(PKV)
+3 ;S DEA=$$GET1^DIQ(200,+PKV,53.2) ; New Person DEA#
+4 ; New Person NPI
SET NPI=$$GET1^DIQ(200,+PKV,41.99)
+5 IF '$LENGTH(DEA)
Begin DoDot:1
+6 ; Institution DEA
SET DEA=$$GET1^DIQ(4,DUZ(2),52)
+7 ;$$GET1^DIQ(9999999.06,DUZ(2),.12) ;CHANGED TO USE NPI INSTEAD OF ASUFAC CODE
SET DEA=DEA_"-"_NPI
End DoDot:1
+8 DO SET(.ARY,"PRA",0)
+9 ; Primary Key value
DO SET(.ARY,PKV,1)
+10 DO SET(.ARY,DEA,6,1,1,1)
+11 DO SET(.ARY,"DEA",6,2,,1)
+12 DO SET(.ARY,NPI,6,1,,2)
+13 DO SET(.ARY,"NPI",6,2,,2)
+14 SET PRA=$$ADDSEG^HLOAPI(.HLST,.ARY)
+15 QUIT
SET(ARY,V,F,C,S,R) ;EP
+1 DO SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
+2 QUIT
+3 ; Failed Transmission Callback
FAILURE ; EP
+1 NEW ARY,SEGIEN
+2 DO PARSE^APSPES2(.DATA,HLMSGIEN,.HLMSTATE)
+3 SET SEGIEN=$$FSEGIEN^APSPES1(.DATA,"MFN")
+4 IF 'SEGIEN
QUIT
+5 DO NOTIF($$GET1^DIQ(200,+PKV,.01)_": Unable to transmit SPI request.")
+6 QUIT
+7 ; Process MFK acknowledgement
MFK ; EP -
+1 NEW ARY,SEGIEN,SEGDAT,PVD,PKV,SPI,SLC
+2 DO PARSE^APSPES2(.DATA,HLMSGIEN,.HLMSTATE)
+3 SET SEGIEN=$$FSEGIEN^APSPES1(.DATA,"MFA")
+4 IF 'SEGIEN
QUIT
+5 MERGE SEGDAT=DATA(SEGIEN)
+6 SET PKV=$$GET^HLOPRS(.SEGDAT,2)
+7 IF $$GET^HLOPRS(.SEGDAT,4)'="S"
Begin DoDot:1
+8 SET SEGIEN=$$FSEGIEN^APSPES1(.DATA,"ERR")
+9 IF SEGIEN
Begin DoDot:2
+10 MERGE SEGDAT=DATA(SEGIEN)
+11 SET ERR=$$GET^HLOPRS(.SEGDAT,8)
+12 IF $LENGTH(ERR)
DO NOTIF($$GET1^DIQ(200,+PKV,.01)_": "_$PIECE(ERR,":"))
End DoDot:2
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 SET SEGIEN=$$FSEGIEN^APSPES1(.DATA,"MFI")
+15 IF 'SEGIEN
QUIT
+16 MERGE SEGDAT=DATA(SEGIEN)
+17 SET SPI=$$GET^HLOPRS(.SEGDAT,1)
+18 ;Service Level code
SET SLC=$$GET^HLOPRS(.SEGDAT,1,4)
+19 DO NOTIF($$GET1^DIQ(200,+PKV,.01)_": Please assign SPI "_SPI_" (SL:"_SLC_") to user.")
End DoDot:1
+20 QUIT
+21 ; Notify SPI mail group
NOTIF(MSG) ; EP -
+1 NEW RET
+2 SET XQAMSG=MSG
+3 SET XQA("G.SPI NOTIFICATION")=""
+4 DO SETUP^XQALERT
+5 QUIT
+6 ; Main entry point for selection of user
EN ; EP -
+1 NEW USR,APSPPOP,NEWRX,REFRX
+2 WRITE @IOF
+3 WRITE !,"Surescripts Provider ID Request Utility",!
+4 SET USR=$$GETIEN1^APSPUTIL(200,"Select Provider: ",-1,,"I $S('$D(^VA(200,Y,0)):0,Y<1:1,$L($P(^(0),U,3)):1,1:0),$P($G(^VA(200,Y,""PS"")),U)")
+5 IF USR<1
QUIT
+6 SET (NEWRX,REFRX)=0
+7 WRITE !!,"Processing request for: "_$$GET1^DIQ(200,+USR,.01)
+8 ; Check for active user
+9 IF '$$ACTIVE^XUSER(+USR)
Begin DoDot:1
+10 WRITE !,"User is not an active RPMS user.",!
+11 DO DIRZ
End DoDot:1
QUIT
+12 ; Check for existing SPI
+13 IF $$SPI^APSPES1(+USR)
Begin DoDot:1
+14 WRITE !,"User has already been assigned an SPI number.",!
+15 DO DIRZ
End DoDot:1
QUIT
+16 ; Ensure that selected user has an NPI
+17 IF '$$GET1^DIQ(200,+USR,41.99)
Begin DoDot:1
+18 WRITE !,"The selected user must have an NPI assigned.",!
+19 DO DIRZ
End DoDot:1
QUIT
+20 ; If needed, indicate that Institutional DEA will be used.
+21 ;I '$L($$GET1^DIQ(200,+USR,53.2)) D
+22 ;.W !,"This provider lacks an individual DEA number."
+23 ;.W !,"The facility DEA number will be used to request the SPI number."
+24 ;.D DIRZ
+25 ;I '$L($$GET1^DIQ(4,DUZ(2),52)) D Q
+26 ;.W !,"The selected facility, "_$$GET1^DIQ(4,DUZ(2),.01)_" lacks a Facility DEA number."
+27 ;.W !,"This will need to be corrected before you can continue with the request."
+28 ;.D DIRZ
+29 IF '$LENGTH($$GET1^DIQ(200,+USR,.136))
Begin DoDot:1
+30 WRITE !,"The user lacks a fax number. This will need to be corrected before you can"
+31 WRITE !,"continue with the request."
+32 DO DIRZ
End DoDot:1
QUIT
+33 IF '$LENGTH($$GET1^DIQ(200,+USR,.151))
Begin DoDot:1
+34 WRITE !,"The user lacks an email address. This will need to be corrected before you can"
+35 WRITE !,"continue with the request."
+36 DO DIRZ
End DoDot:1
QUIT
+37 IF '$LENGTH($$GET1^DIQ(9999999.06,DUZ(2),.13))
Begin DoDot:1
+38 WRITE !,"The selected facility, "_$$GET1^DIQ(4,DUZ(2),.01)_" lacks a phone number."
+39 WRITE !,"This will need to be corrected before you can continue with the request."
+40 DO DIRZ
End DoDot:1
QUIT
+41 ;IHS/MSC/PLS - 05/24/2012
+42 IF $$DIRYN^APSPUTIL("Will provider be writing New prescriptions electronically","YES",,.APSPPOP)
Begin DoDot:1
+43 SET NEWRX=1
End DoDot:1
+44 ;I $$DIRYN^APSPUTIL("Will provider be taking Refill Requests electronically","NO",,.APSPPOP) D
+45 IF $$DIR^APSPUTIL("SA^0:NO","Will provider be taking Refill Requests electronically? ","No")
+46
*** ERROR ***
+47 IF $$DIRYN^APSPUTIL("Request SPI","YES",,.APSPPOP)
Begin DoDot:1
+48 DO ADDPRV(USR,"MAD")
+49 WRITE !!,"An SPI number has been requested. A Kernel Alert will be sent to"
+50 WRITE !,"the SPI NOTIFICATION group when the SPI number is received."
End DoDot:1
+51 QUIT
+52 ;
DIRZ ;EP - Prompt to continue
+1 DO DIRZ^APSPUTIL("Press ENTER to continue")
+2 QUIT
+3 ;
FNDTYP(IEN) ;EP - Determine if a new or update message should be sent
+1 ;If MFNTYP exists, no need to do the lookup
+2 IF $DATA(MFNTYP)
QUIT MFNTYP
+3 NEW TD,ENTER,ACTIVE,RES
+4 SET TD=$$DT^XLFDT()
+5 ; Date Entered
SET ENTER=$PIECE($GET(^VA(200,IEN,1)),U,7)
+6 IF TD>ENTER
SET RES="MUP1"
+7 IF ENTER=TD
Begin DoDot:1
+8 IF $PIECE($GET(^VA(200,IEN,1.1)),U,1)'=""
SET RES="MUP1"
+9 IF $PIECE($GET(^VA(200,IEN,1.1)),U,1)=""
SET RES="MAD"
End DoDot:1
+10 IF $PIECE($GET(^VA(200,IEN,0)),U,11)!($PIECE($GET(^VA(200,IEN,"PS")),U,4))
SET RES="MDC"
+11 QUIT RES
+12 ;
ADDPTL(PVD) ;EP - Entry point for APSP ERX MFN UPDATE protocol
+1 ;Additional business rules to be added here
+2 DO ADDPRV(PVD)
+3 QUIT
PRVDEA(PKV) ;EP-
+1 NEW DEA,NPI
+2 ; New Person DEA#
SET DEA=$$GET1^DIQ(200,+PKV,53.2)
+3 ; New Person NPI
SET NPI=$$GET1^DIQ(200,+PKV,41.99)
+4 IF '$LENGTH(DEA)
Begin DoDot:1
+5 ; Institution DEA
SET DEA=$$GET1^DIQ(4,DUZ(2),52)
+6 SET DEA=DEA_"-"_NPI
End DoDot:1
+7 QUIT DEA
