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

APSPES9.m

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