APSPFNC2 ;IHS/MSC/PLS - Prescription Creation Support ;07-Jul-2015 15:21;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1005,1006,1007,1008,1009,1011,1013,1015,1016,1017,1019**;Sep 23, 2004;Build 4
;=================================================================
; Create a verified prescription
MAKEVRX(DATA,RXORD) ;
F RXORD=0:0 S RXORD=$O(RXORD(RXORD)) Q:'RXORD D
.D CREATE(RXORD(RXORD),1)
Q
; Call Pharmacy Package
CREATE(ORIEN,FORCE) ;
N PSOX,NODE0,ORD,OR0,USER1,SIGOK,PSODRUG,PSONEW,PSOMAX,PSOMSG,PSODFN,PSOCOU
N PSOCOUU,PSOCS,PSOFDR,PSONOOR,PSOPAR,PSORX,PSOSITE,RXFL,RXORD,SEG1,SPEED
N TALK,ARY,RET,PRC,PSOINSFL,IEN,INSTIEN,EPHMFLG,RNWORDER,PICKUP,APSPPRIO
S FORCE=$G(FORCE,0)
S IEN=0
S ORIEN=+$G(ORIEN)
Q:'ORIEN
S PSOSITE=$$LOC(ORIEN)
Q:'PSOSITE
S INSTIEN=+$$GET1^DIQ(59,PSOSITE,100,"I")
S ORD=$G(^OR(100,ORIEN,4)) ; Get pending order #
Q:ORD'["S" ; Not a pending outpatient med order or already processed
S ORD=+ORD
Q:'ORD!('$D(^PS(52.41,ORD,0)))
S EPHMFLG=$$GET^XPAR("DIV.`"_DUZ(2)_"^SYS","APSP AUTO RX")
S OR0=^PS(52.41,ORD,0)
S PSONEW("ELECTRONIC PHARMACY")=$$VALUE^ORCSAVE2(+OR0,"PHARMACY")
S PSONEW("DAW")=$$VALUE^ORCSAVE2(+OR0,"DAW")
S PICKUP=$$VALUE^ORCSAVE2(+OR0,"PICKUP")
S:(EPHMFLG=2)&(PICKUP="C") FORCE=1 ;P11
S:(EPHMFLG>0)&(PICKUP="P") FORCE=1 ;P11
I 'FORCE Q:((EPHMFLG=1!(EPHMFLG=2))&'PSONEW("ELECTRONIC PHARMACY"))
S PSODFN=+$P(OR0,U,2)
S RNWORDER=$P(OR0,U,21)
S APSPPRIO="" ;P13 Set priority variable
S (OI,PSODRUG("OI"))=+$P(OR0,U,8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9)
I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR
E D DREN^PSOORNW2
I '$G(PSODRUG("IEN")) D Q ; No drug
.N DFN,POIN
.S DFN=+$P(OR0,U,2)
.S POIN=$$GET1^DIQ(50.7,$P(OR0,U,8),.01)
.D NOTIF(DUZ,DFN,ORIEN,"Unable to generate "_POIN_" prescription for "_$$GET1^DIQ(2,DFN,.01),"Missing Drug")
.D AFLOG(.RET,+OR0,0,"No available drug for "_POIN)
;
DRG I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),"CLOZ1")),"^")="PSOCLO1" D CLOZ^PSOORFI2
S PSODRUG("DEA")=1
I $G(PSODRUG("DEA"))]"" D
.S PSOCS=0 K DIR,DIC,PSOX
.F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOCS,"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOCS,"^",2)=1
.S PSOMAX=$S($G(CLOZPAT)=0:0,$G(CLOZPAT)=1:1,PSOCS&('$G(CLOZPAT)):5,1:11) I '$G(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S PSOMAX=0
E S PSOMAX=$S($G(CLOZPAT)=1:1,1:$P(OR0,"^",11))
;
D DOSE(ORD)
;
D AUTO^PSONRXN
S PSONEW("RX #")="X"_PSONEW("RX #")
S PSOX=PSONEW("RX #")
S PSONEW("AUTOFIN")=1
;
S PSONEW("ISSUE DATE")=$S($P($G(OR0),U,6):$E($P(OR0,U,6),1,7),1:DT)
S PSONEW("PATIENT STATUS")=$S(+$G(^PS(55,PSODFN,"PS")):+$G(^PS(55,PSODFN,"PS")),1:"")
S:'PSONEW("PATIENT STATUS") PSONEW("PATIENT STATUS")=$S($$GET^XPAR("DIV.`"_INSTIEN_"^SYS","APSP AUTO RX DEF PT STATUS"):$$GET^XPAR("DIV.`"_INSTIEN_"^SYS","APSP AUTO RX DEF PT STATUS"),1:"")
S PSONEW("PROVIDER")=+$P(OR0,U,5)
S PSONEW("QTY")=$P(OR0,U,10)
S PSONEW("MAIL/WINDOW")=$S($P(OR0,U,17)="M":"M",1:"W")
D USER^PSOORFI2($P(OR0,U,5))
S PSONEW("CLERK CODE")=$P(OR0,U,4),PSONEW("PROVIDER")=$P(OR0,U,5),PSONEW("PROVIDER NAME")=USER1
S PSONEW("CM")=$S($L($$VALUE^ORCSAVE2(+OR0,"CMF")):$$VALUE^ORCSAVE2(+OR0,"CMF"),1:"N")
S PSONEW("CLININD")=$S($L($$VALUE^ORCSAVE2(+OR0,"CLININD")):$$VALUE^ORCSAVE2(+OR0,"CLININD"),1:"")
S PSONEW("CLININD2")=$S($L($$VALUE^ORCSAVE2(+OR0,"CLININD2")):$$VALUE^ORCSAVE2(+OR0,"CLININD2"),1:"")
S PSONEW("SNMDCNPTID")=$S($L($$VALUE^ORCSAVE2(+OR0,"SNMDCNPTID")):$$VALUE^ORCSAVE2(+OR0,"SNMDCNPTID"),1:"")
S PSONEW("DSCMED")=$S($L($$VALUE^ORCSAVE2(+OR0,"DSCMED")):$$VALUE^ORCSAVE2(+OR0,"DSCMED"),1:"") ;P1017
S PSONEW("DAYS SUPPLY")=$P(OR0,U,22)
S PSONEW("ELECTRONIC PHARMACY")=$S($$VALUE^ORCSAVE2(+OR0,"PHARMACY"):$$VALUE^ORCSAVE2(+OR0,"PHARMACY"),1:"")
S PSONEW("# OF REFILLS")=$P(OR0,U,11) ;$S(+$P(OR0,"^",11)>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11))
S PSONEW("CLINIC")=+$P(OR0,"^",13)
S PSONEW("LOGIN DATE")=+$P(OR0,U,12)
S (Y,PSONEW("FILL DATE"))=$S($E($P(OR0,"^",6),1,7)<DT:DT,1:DT) X ^DD("DD") S PSORX("FILL DATE")=Y
S PSONEW("DISPENSE DATE")=DT
S PSONEW("EXPIRATION DATE")=$$FMADD^XLFDT(DT,$S(+$P(OR0,U,22)>0:+$P(OR0,U,22),1:10))
S PSONEW("STOP DATE")=PSONEW("EXPIRATION DATE")
S PSONEW("LAST DISPENSE DATE")=DT
S PSONEW("POE")=1
;IHS/MSC/PLS - added $S - p1019
S PSONEW("REMARKS")=$S(EPHMFLG=2&(PICKUP="C"):"AUTOFINISHED ADMINISTERED IN CLINIC",1:"AUTOFINISHED PRESCRIPTION")
;IHS/MSC/MGH Patch 13 get pickup type
S PSONEW("PICKUP")=PICKUP
S SPEED=1
S PSONEW("STATUS")=0 ;Set STATUS to Active
S PSOFDR=1
S PSOINSFL=$P($G(^PS(52.41,ORD,"INS")),"^",2) ; Patient Instruction Flag
D INSCMT
D INS1
D SIG
D GETPRVI
;
D EN^PSON52(.PSONEW)
S ARY("COM")="Autofinished RX for external fill"
S ARY("REASON")="B"
S ARY("RX REF")=0
D UPTLOG(.RET,+$G(PSONEW("IRXN")),0,.ARY)
D AFLOG(.RET,+OR0,1)
D EN^PSOHLSN1(PSONEW("IRXN"),"SC","CM")
D EN^PSOHLSN1(PSONEW("IRXN"),"OK","CM")
D EN^APSPELRX(PSONEW("IRXN"),PSONEW("ELECTRONIC PHARMACY"))
;Handle renewed prescription
D CHKRNW(PSONEW("IRXN"))
Q
;
; Find a site
LOC(ORIEN) ; PEP
Q $$LOC^APSPFNC6(ORIEN)
;
INSCMT ; Extract provider comments
I $O(^PS(52.41,ORD,2,0)) D
.S PHI=^PS(52.41,ORD,2,0),T=0 D
..F S T=$O(^PS(52.41,ORD,2,T)) Q:'T S PHI(T)=^PS(52.41,ORD,2,T,0)
I $O(^PS(52.41,ORD,3,0)) D
.S PRC=^PS(52.41,ORD,3,0),T=0 D
..F S T=$O(^PS(52.41,ORD,3,T)) Q:'T S PRC(T)=^PS(52.41,ORD,3,T,0)
Q
INS1 ;
N INST,MIG,SG,JUNK,IEN,SINS1
S IEN=1
S INST=0 F S INST=$O(^PS(52.41,ORD,"INS1",INST)) Q:'INST S (MIG,PSONEW("SIG",INST))=^PS(52.41,ORD,"INS1",INST,0) D
.F SG=1:1:$L(MIG," ") S IEN=IEN+1,$P(JUNK("PSOPO",$J,IEN,0)," ",20)=" " S JUNK("PSOPO",$J,IEN,0)=$G(JUNK("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG)
I $P($G(^PS(55,PSODFN,"LAN")),"^"),$O(^PS(52.41,ORD,"INS1",0)) D
.I $G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S (X,PSONEW("SINS"))=^PS(50.7,PSODRUG("OI"),"INS1") D SSIG^PSOHELP
.I $G(SINS1)]"" S PSONEW("SINS")=$E(SINS1,2,250)
.S IEN=IEN+1,JUNK("PSOPO",$J,IEN,0)=" Other Pat Instruct: "_$S($G(PSONEW("SINS"))]"":PSONEW("SINS"),1:"")
Q
;
SIG ;
S SIG=0,PSOFINFL=1 F S SIG=$O(^PS(52.41,ORD,"SIG",SIG)) Q:'SIG D
.S SIG(SIG)=^PS(52.41,ORD,"SIG",SIG,0)
D EN^PSOFSIG(.PSONEW)
S:$O(SIG(0)) SIGOK=1
F D=0:0 S D=$O(^PS(52.41,ORD,"INS1",D)) Q:'D D
.S PSONEW("INS",D)=^PS(52.41,ORD,"INS1",D,0)
Q
; Update activity or label log and return success flag
; Input: RX - IEN to Prescription File (52)
; TYPE - 0=Activity, 1=Label, 2=Reprint
; ARY - Holds data for log type
UPTLOG(DATA,RX,TYPE,ARY) ;EP
N FDA,ERR,FN,IENS,USR
S IENS="+1,"_RX_","
S USR=$S($G(ARY("USER")):ARY("USER"),1:DUZ)
S DATA=0
I '$G(TYPE)!($G(TYPE)=2) D ;Activity Log
.S FN=52.3
.S FDA(FN,IENS,.01)=$$NOW^XLFDT()
.S FDA(FN,IENS,.02)=$G(ARY("REASON"))
.S FDA(FN,IENS,.03)=USR
.S FDA(FN,IENS,.04)=$G(ARY("RX REF"))
.S FDA(FN,IENS,.05)=$E($G(ARY("COM")),1,75)
.S FDA(FN,IENS,9999999.01)=$G(ARY("DEV"))
.S FDA(FN,IENS,9999999.02)=$G(ARY("TYPE"))
E I $G(TYPE)=1 D ;Print Label Log
.S FN=52.032
.S FDA(FN,IENS,.01)=$$NOW^XLFDT()
.S FDA(FN,IENS,1)=$G(ARY("RX REF"))
.S FDA(FN,IENS,2)=$G(ARY("COM"))
.S FDA(FN,IENS,3)=USR
.S FDA(FN,IENS,5)=$G(ARY("DEV"))
D UPDATE^DIE(,"FDA",,"ERR")
I '$D(ERR) S DATA=1
E S DATA="0^Unable to update log"
Q
;
; Log autofinish activity
; Input: OIEN - Order IEN
; SUC - Successful flag
; COM - Comment for unsuccessful
AFLOG(DATA,OIEN,SUC,COM) ;EP
N FDA,ERR,FN
I '$G(SUC),$O(^APSPAF("C",+$G(OIEN),0)) Q
S IENS="+1,"
S DATA=0
S FN=9009033.92
S FDA(FN,IENS,.01)=$$NOW^XLFDT()
S FDA(FN,IENS,.02)=$G(OIEN)
S FDA(FN,IENS,.03)=$G(SUC)
S FDA(FN,IENS,.04)=$G(COM)
D UPDATE^DIE(,"FDA",,"ERR")
I '$D(ERR) S DATA=1
E S DATA="0^Unable to update log"
Q
;
GETPRVI ; EP-Get provider instructions
Q:'$O(PRC(0))!'$$GET^XPAR("DIV.`"_INSTIEN_"^SYS","APSP AUTO RX ADD PRV COMMENT")
N NI,NC
S PSOPRC=1,NI=0 F I=0:0 S I=$O(PSONEW("SIG",I)) Q:'I S NI=I
D EXPPRC^PSOORFI4(.PRC)
S NC=0 F I=0:0 S I=$O(PRC(I)) Q:'I S NC=NC+1
I NI'>1,NC=1,($L($G(PSONEW("SIG",NI)))+$L(PRC(1)))'>250 D
.S PSONEW("SIG",1)=$G(PSONEW("SIG",NI))_" "_PRC(1)
.S:$E(PSONEW("SIG",1))=" " PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250) S PSONEW("INS")=PSONEW("SIG",1)
E D
.F I=0:0 S I=$O(PRC(I)) Q:'I S NI=NI+1,(PSONEW("SIG",NI),PSONEW("INS",NI))=PRC(I)
.I $E(PSONEW("SIG",1))=" " S PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250)
D EN^PSOFSIG(.PSONEW)
Q
;
ADDPCSIG ;EP - Add provider comments to SIG
N LP,LP1,SCNT
S SCNT=$O(SIG($C(1)),-1)
S LP=0 F S LP=$O(PSONEW("SIG",LP)) Q:'LP D
.S SCNT=SCNT+1 S SIG(SCNT)=$G(PSONEW("SIG",LP))
.S SIG(SCNT)=$$UP^XLFSTR(SIG(SCNT))
Q
DOSE(ORD) ;pending orders
N DOSE,DOSE1,I,UNITS,ROUTE,DOENT
S DOENT=0
F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D
.S PSONEW("DOSE",I)=$P(DOSE1,"^"),PSONEW("DOSE ORDERED",I)=$P(DOSE1,"^",2),PSONEW("UNITS",I)=$P(DOSE,"^",9),PSONEW("NOUN",I)=$P(DOSE,"^",5)
.S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^")
.S PSONEW("VERB",I)=$P(DOSE,"^",10),PSONEW("ROUTE",I)=$P(DOSE,"^",8)
.S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^")
.S PSONEW("SCHEDULE",I)=$P(DOSE,"^"),PSONEW("DURATION",I)=$P(DOSE,"^",2)
.S PSONEW("DURATION",I)=$S($E(PSONEW("DURATION",I),1)'?.N:$E(PSONEW("DURATION",I),2,99)_$E(PSONEW("DURATION",I),1),1:PSONEW("DURATION",I)) ;IHS/MSC/MGH - P1013
.;S DOENT=$G(DOENT)+1 S PSONEW("CONJUNCTION",I)=$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="S":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"") ;IHSMSC/PLS - P1015
.S DOENT=$G(DOENT)+1 S PSONEW("CONJUNCTION",I)=$P(DOSE,"^",6)
S PSONEW("ENT")=DOENT
Q
;Return list of pharmacies from APSP PHARMACY LIST
PHMLST(DATA,ZIP,RAD) ;EP
N IEN,CNT,ZARY,ZC,PTYPE
S DATA=$NA(^TMP("APSPOPHM",$J))
K @DATA
Q:'$G(ZIP)
D GETZC(.ZARY,ZIP,RAD)
S ZC="",CNT=0 F S ZC=$O(ZARY(ZC)) Q:'$L(ZC) D
.S IEN=0 F S IEN=$O(^APSPOPHM("ZIP",ZC,IEN)) Q:'IEN D ADDPHM(IEN,ZARY(ZC))
I $$GET^XPAR("ALL","APSP SS PHARMACY MAILORDER") D
.S PTYPE=1
.S LP=0
.F S LP=$O(^APSPOPHM(LP)) Q:'LP D
..D:$$SPECID^APSPFNC5(LP,PTYPE,1) ADDPHM(LP,99)
Q
;Return list of pharmacies from IEN list
PHMLST2(DATA,IEN) ;EP
N CNT
S DATA=$NA(^TMP("APSPOPHM",$J))
K @DATA
S:$G(IEN) IEN(-1)=IEN
S IEN="",CNT=0
F S IEN=$O(IEN(IEN)) Q:IEN="" D ADDPHM(+IEN(IEN),,0)
Q
ADDPHM(IEN,DIST,NEWRX) ;
N N0,N1,N2,N7,N8,I,ID,SPEC,SVL
S SPEC=""
S NEWRX=$G(NEWRX,1)
S N0=$G(^APSPOPHM(IEN,0)),N1=$G(^(1)),N2=$G(^(2)),N7=$G(^(7))
Q:'$L(N0)
S SVL=$P(N0,U,5)
I NEWRX Q:'(SVL#2) ;P12 Only return NEWRX service level
I N7,DT<N7 Q
I $P(N7,U,2),DT>$P(N7,U,2) Q
S CNT=CNT+1,DIST=$G(DIST)
;IHS/MSC/MGH Update for specialty IDs
I $D(^APSPOPHM(IEN,8)) D
.S I=0 F S I=$O(^APSPOPHM(IEN,8,I)) Q:I="" D
..S ID=$G(^APSPOPHM(IEN,8,I,0))
..S ID=$S(ID=1:"MAIL ORDER",ID=2:"FAX",ID=8:"RETAIL",ID=16:"SPECIALTY",ID=32:"LONG-TERM CARE",ID=64:"24 HOUR",1:"")
..I ID'="" D
...I SPEC="" S SPEC=ID
...E S SPEC=SPEC_","_ID
; IEN^StoreName^Address1 Address2^City^State^Zip^PFAX^PPhone^Distance^Specialty
S @DATA@(+DIST,CNT)=IEN_U_$P(N0,U,10)_U_$P(N1,U)_" "_$P(N1,U,2)_U_$P(N1,U,3)_U_$P(N1,U,4)_U_$P(N1,U,5)_U_$P(N2,U,2)_U_$P(N2,U)_U_$FN(DIST,"",2)_U_SPEC
Q
; Return array of zipcodes for given zipcode
; Input: ARY - return array - pass by reference
; ZIP - 5 DIGIT ZIP CODE
; R - radius
; Output: ARY(ZC)=radius
;
GETZC(ARY,ZIP,R) ;EP
N ZIEN,ZC,D,RAD
K ARY
S ZIEN=$O(^APSPZCPX("B",ZIP,0)) Q:'ZIEN D
.S RAD="" F S RAD=$O(^APSPZCPX(ZIEN,1,"B",RAD)) Q:RAD=""!(RAD>R) D
..S ZC=0 F S ZC=$O(^APSPZCPX(ZIEN,1,"B",RAD,ZC)) Q:'ZC D
...S ARY($P(^APSPZCPX(ZC,0),U))=RAD
Q
; Returns ability of user to e-prescribe
; Input: USR - IEN to New Person File
; Output: 0 = e-Prescribing is not available to user
; 1 = e-Prescribing is available to user
ERXUSER(DATA,USR) ; EP
S DATA=1
I $G(USR) D
.S DATA=''$L($$SPI^APSPES1(USR))
.S:'DATA DATA=+$$GET^XPAR($$ENT^CIAVMRPC("APSP AUTO RX ELECTRONIC",.ENT,USR),"APSP AUTO RX ELECTRONIC")
Q
; Returns availablity of Orderable Item to be e-prescribed
; Input: OIIEN - Orderable Item IEN
; SCH - String of schedules - defaults to 2345
ERXOI(DATA,OIIEN,SCH) ; EP
N PSOI
S DATA=1,SCH=$G(SCH,"2345")
I $G(OIIEN) D
.S PSOI=+$P($G(^ORD(101.43,+OIIEN,0)),U,2) ; Pharmacy Orderable Item IEN
.S DIEN=0 F S DIEN=$O(^PSDRUG("ASP",PSOI,DIEN)) Q:'DIEN D Q:'DATA
..S DATA='$$ISSCH(DIEN,SCH)
Q
; Returns result of DEA Special Handling Comparison
; Input : ORD = Order ID
; CLS = Drug class
DEACLS(DATA,ORD,CLS) ; EP -
N PSOI,OIIEN
S OIIEN=$$VALUE^ORCSAVE2(+ORD,"ORDERABLE")
S DATA=0
I $G(OIIEN) D
.S PSOI=+$P($G(^ORD(101.43,+OIIEN,0)),U,2) ; Pharmacy Orderable Item IEN
.S DIEN=0 F S DIEN=$O(^PSDRUG("ASP",PSOI,DIEN)) Q:'DIEN D Q:DATA
..S DATA=$$ISSCH(DIEN,CLS)
Q
; Check for schedule drugs
ISSCH(DRUG,SCH) ;PEP - Returns boolean value
N DS,RES
S RES=0
S DS=+$P(^PSDRUG(DRUG,0),U,3)
S RES=SCH[DS
Q RES
; Notify user of autofinish failure
; Input: USR - User IEN
; DFN - Patient IEN
; ORIEN - Order IEN
; MSG - Message text
; ALRTD - Alert data
NOTIF(USR,DFN,ORIEN,MSG,ALRTD) ;EP -
N XQA,XQAID,XQADATA,XQAMSG
S XQA(USR)=""
S XQAMSG="Autofinish Failure:"_$G(MSG)
S XQAID="OR"_","_DFN_","_99003
S:$G(ORIEN) XQADATA=ORIEN_"@"_$G(ALRTD)
D SETUP^XQALERT
Q
; Check for renewed prescription
; Input: RXIEN- IEN to File 52
CHKRNW(RXIEN) ;
;Check Placer ID of RXIEN
; Check Replaced Order # field value
; Check Status of Replaced Order order
; If RENEWED then set:
; - Activity Log - RENEWED
Q:'$G(RXIEN)
N PLACER,ORGIEN,RENEWED,ORGPKGID,ORXNUM ;,PSORENW,PSONEW
N REA,DA,MSG,PSCAN
S PLACER=$$GET1^DIQ(52,RXIEN,39.3)
Q:'PLACER
S ORGIEN=$$GET1^DIQ(100,PLACER,9,"I")
Q:'ORGIEN ;No renewed order
S RENEWED=$$GET1^DIQ(100,ORGIEN,5,"I")=15
Q:'RENEWED
S ORGPKGID=+$$GET1^DIQ(100,ORGIEN,33,"I")
Q:'ORGPKGID
S ORXNUM=$$GET1^DIQ(52,ORGPKGID,.01)
S REA="C",DA=ORGPKGID
S MSG="Renewed/Updated from RPMS EHR"
S PSCAN(ORXNUM)=DA_"^C"
D CAN^PSOCAN
D:RNWORDER
.D SETDATA(RNWORDER,52,"39.5///"_"`"_RXIEN)
.D SETDATA(RXIEN,52,"39.4///"_"`"_RNWORDER)
Q
;
SETDATA(DA,DIE,DR) ;
D ^DIE
Q
APSPFNC2 ;IHS/MSC/PLS - Prescription Creation Support ;07-Jul-2015 15:21;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1005,1006,1007,1008,1009,1011,1013,1015,1016,1017,1019**;Sep 23, 2004;Build 4
+2 ;=================================================================
+3 ; Create a verified prescription
MAKEVRX(DATA,RXORD) ;
+1 FOR RXORD=0:0
SET RXORD=$ORDER(RXORD(RXORD))
IF 'RXORD
QUIT
Begin DoDot:1
+2 DO CREATE(RXORD(RXORD),1)
End DoDot:1
+3 QUIT
+4 ; Call Pharmacy Package
CREATE(ORIEN,FORCE) ;
+1 NEW PSOX,NODE0,ORD,OR0,USER1,SIGOK,PSODRUG,PSONEW,PSOMAX,PSOMSG,PSODFN,PSOCOU
+2 NEW PSOCOUU,PSOCS,PSOFDR,PSONOOR,PSOPAR,PSORX,PSOSITE,RXFL,RXORD,SEG1,SPEED
+3 NEW TALK,ARY,RET,PRC,PSOINSFL,IEN,INSTIEN,EPHMFLG,RNWORDER,PICKUP,APSPPRIO
+4 SET FORCE=$GET(FORCE,0)
+5 SET IEN=0
+6 SET ORIEN=+$GET(ORIEN)
+7 IF 'ORIEN
QUIT
+8 SET PSOSITE=$$LOC(ORIEN)
+9 IF 'PSOSITE
QUIT
+10 SET INSTIEN=+$$GET1^DIQ(59,PSOSITE,100,"I")
+11 ; Get pending order #
SET ORD=$GET(^OR(100,ORIEN,4))
+12 ; Not a pending outpatient med order or already processed
IF ORD'["S"
QUIT
+13 SET ORD=+ORD
+14 IF 'ORD!('$DATA(^PS(52.41,ORD,0)))
QUIT
+15 SET EPHMFLG=$$GET^XPAR("DIV.`"_DUZ(2)_"^SYS","APSP AUTO RX")
+16 SET OR0=^PS(52.41,ORD,0)
+17 SET PSONEW("ELECTRONIC PHARMACY")=$$VALUE^ORCSAVE2(+OR0,"PHARMACY")
+18 SET PSONEW("DAW")=$$VALUE^ORCSAVE2(+OR0,"DAW")
+19 SET PICKUP=$$VALUE^ORCSAVE2(+OR0,"PICKUP")
+20 ;P11
IF (EPHMFLG=2)&(PICKUP="C")
SET FORCE=1
+21 ;P11
IF (EPHMFLG>0)&(PICKUP="P")
SET FORCE=1
+22 IF 'FORCE
IF ((EPHMFLG=1!(EPHMFLG=2))&'PSONEW("ELECTRONIC PHARMACY"))
QUIT
+23 SET PSODFN=+$PIECE(OR0,U,2)
+24 SET RNWORDER=$PIECE(OR0,U,21)
+25 ;P13 Set priority variable
SET APSPPRIO=""
+26 SET (OI,PSODRUG("OI"))=+$PIECE(OR0,U,8)
SET PSODRUG("OIN")=$PIECE(^PS(50.7,$PIECE(OR0,"^",8),0),"^")
SET OID=$PIECE(OR0,"^",9)
+27 IF $PIECE($GET(OR0),"^",9)
SET POERR=1
SET DREN=$PIECE(OR0,"^",9)
DO DRG^PSOORDRG
KILL POERR
+28 IF '$TEST
DO DREN^PSOORNW2
+29 ; No drug
IF '$GET(PSODRUG("IEN"))
Begin DoDot:1
+30 NEW DFN,POIN
+31 SET DFN=+$PIECE(OR0,U,2)
+32 SET POIN=$$GET1^DIQ(50.7,$PIECE(OR0,U,8),.01)
+33 DO NOTIF(DUZ,DFN,ORIEN,"Unable to generate "_POIN_" prescription for "_$$GET1^DIQ(2,DFN,.01),"Missing Drug")
+34 DO AFLOG(.RET,+OR0,0,"No available drug for "_POIN)
End DoDot:1
QUIT
+35 ;
DRG IF $PIECE($GET(^PSDRUG(+$GET(PSODRUG("IEN")),"CLOZ1")),"^")="PSOCLO1"
DO CLOZ^PSOORFI2
+1 SET PSODRUG("DEA")=1
+2 IF $GET(PSODRUG("DEA"))]""
Begin DoDot:1
+3 SET PSOCS=0
KILL DIR,DIC,PSOX
+4 FOR DEA=1:1
IF $EXTRACT(PSODRUG("DEA"),DEA)=""
QUIT
IF $EXTRACT(+PSODRUG("DEA"),DEA)>1
IF $EXTRACT(+PSODRUG("DEA"),DEA)<6
SET $PIECE(PSOCS,"^")=1
IF $EXTRACT(+PSODRUG("DEA"),DEA)=2
SET $PIECE(PSOCS,"^",2)=1
+5 SET PSOMAX=$SELECT($GET(CLOZPAT)=0:0,$GET(CLOZPAT)=1:1,PSOCS&('$GET(CLOZPAT)):5,1:11)
IF '$GET(CLOZPAT)
IF PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")
SET PSOMAX=0
End DoDot:1
+6 IF '$TEST
SET PSOMAX=$SELECT($GET(CLOZPAT)=1:1,1:$PIECE(OR0,"^",11))
+7 ;
+8 DO DOSE(ORD)
+9 ;
+10 DO AUTO^PSONRXN
+11 SET PSONEW("RX #")="X"_PSONEW("RX #")
+12 SET PSOX=PSONEW("RX #")
+13 SET PSONEW("AUTOFIN")=1
+14 ;
+15 SET PSONEW("ISSUE DATE")=$SELECT($PIECE($GET(OR0),U,6):$EXTRACT($PIECE(OR0,U,6),1,7),1:DT)
+16 SET PSONEW("PATIENT STATUS")=$SELECT(+$GET(^PS(55,PSODFN,"PS")):+$GET(^PS(55,PSODFN,"PS")),1:"")
+17 IF 'PSONEW("PATIENT STATUS")
SET PSONEW("PATIENT STATUS")=$SELECT($$GET^XPAR("DIV.`"_INSTIEN_"^SYS","APSP AUTO RX DEF PT STATUS"):$$GET^XPAR("DIV.`"_INSTIEN_"^SYS","APSP AUTO RX DEF PT STATUS"),1:"")
+18 SET PSONEW("PROVIDER")=+$PIECE(OR0,U,5)
+19 SET PSONEW("QTY")=$PIECE(OR0,U,10)
+20 SET PSONEW("MAIL/WINDOW")=$SELECT($PIECE(OR0,U,17)="M":"M",1:"W")
+21 DO USER^PSOORFI2($PIECE(OR0,U,5))
+22 SET PSONEW("CLERK CODE")=$PIECE(OR0,U,4)
SET PSONEW("PROVIDER")=$PIECE(OR0,U,5)
SET PSONEW("PROVIDER NAME")=USER1
+23 SET PSONEW("CM")=$SELECT($LENGTH($$VALUE^ORCSAVE2(+OR0,"CMF")):$$VALUE^ORCSAVE2(+OR0,"CMF"),1:"N")
+24 SET PSONEW("CLININD")=$SELECT($LENGTH($$VALUE^ORCSAVE2(+OR0,"CLININD")):$$VALUE^ORCSAVE2(+OR0,"CLININD"),1:"")
+25 SET PSONEW("CLININD2")=$SELECT($LENGTH($$VALUE^ORCSAVE2(+OR0,"CLININD2")):$$VALUE^ORCSAVE2(+OR0,"CLININD2"),1:"")
+26 SET PSONEW("SNMDCNPTID")=$SELECT($LENGTH($$VALUE^ORCSAVE2(+OR0,"SNMDCNPTID")):$$VALUE^ORCSAVE2(+OR0,"SNMDCNPTID"),1:"")
+27 ;P1017
SET PSONEW("DSCMED")=$SELECT($LENGTH($$VALUE^ORCSAVE2(+OR0,"DSCMED")):$$VALUE^ORCSAVE2(+OR0,"DSCMED"),1:"")
+28 SET PSONEW("DAYS SUPPLY")=$PIECE(OR0,U,22)
+29 SET PSONEW("ELECTRONIC PHARMACY")=$SELECT($$VALUE^ORCSAVE2(+OR0,"PHARMACY"):$$VALUE^ORCSAVE2(+OR0,"PHARMACY"),1:"")
+30 ;$S(+$P(OR0,"^",11)>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11))
SET PSONEW("# OF REFILLS")=$PIECE(OR0,U,11)
+31 SET PSONEW("CLINIC")=+$PIECE(OR0,"^",13)
+32 SET PSONEW("LOGIN DATE")=+$PIECE(OR0,U,12)
+33 SET (Y,PSONEW("FILL DATE"))=$SELECT($EXTRACT($PIECE(OR0,"^",6),1,7)<DT:DT,1:DT)
XECUTE ^DD("DD")
SET PSORX("FILL DATE")=Y
+34 SET PSONEW("DISPENSE DATE")=DT
+35 SET PSONEW("EXPIRATION DATE")=$$FMADD^XLFDT(DT,$SELECT(+$PIECE(OR0,U,22)>0:+$PIECE(OR0,U,22),1:10))
+36 SET PSONEW("STOP DATE")=PSONEW("EXPIRATION DATE")
+37 SET PSONEW("LAST DISPENSE DATE")=DT
+38 SET PSONEW("POE")=1
+39 ;IHS/MSC/PLS - added $S - p1019
+40 SET PSONEW("REMARKS")=$SELECT(EPHMFLG=2&(PICKUP="C"):"AUTOFINISHED ADMINISTERED IN CLINIC",1:"AUTOFINISHED PRESCRIPTION")
+41 ;IHS/MSC/MGH Patch 13 get pickup type
+42 SET PSONEW("PICKUP")=PICKUP
+43 SET SPEED=1
+44 ;Set STATUS to Active
SET PSONEW("STATUS")=0
+45 SET PSOFDR=1
+46 ; Patient Instruction Flag
SET PSOINSFL=$PIECE($GET(^PS(52.41,ORD,"INS")),"^",2)
+47 DO INSCMT
+48 DO INS1
+49 DO SIG
+50 DO GETPRVI
+51 ;
+52 DO EN^PSON52(.PSONEW)
+53 SET ARY("COM")="Autofinished RX for external fill"
+54 SET ARY("REASON")="B"
+55 SET ARY("RX REF")=0
+56 DO UPTLOG(.RET,+$GET(PSONEW("IRXN")),0,.ARY)
+57 DO AFLOG(.RET,+OR0,1)
+58 DO EN^PSOHLSN1(PSONEW("IRXN"),"SC","CM")
+59 DO EN^PSOHLSN1(PSONEW("IRXN"),"OK","CM")
+60 DO EN^APSPELRX(PSONEW("IRXN"),PSONEW("ELECTRONIC PHARMACY"))
+61 ;Handle renewed prescription
+62 DO CHKRNW(PSONEW("IRXN"))
+63 QUIT
+64 ;
+65 ; Find a site
LOC(ORIEN) ; PEP
+1 QUIT $$LOC^APSPFNC6(ORIEN)
+2 ;
INSCMT ; Extract provider comments
+1 IF $ORDER(^PS(52.41,ORD,2,0))
Begin DoDot:1
+2 SET PHI=^PS(52.41,ORD,2,0)
SET T=0
Begin DoDot:2
+3 FOR
SET T=$ORDER(^PS(52.41,ORD,2,T))
IF 'T
QUIT
SET PHI(T)=^PS(52.41,ORD,2,T,0)
End DoDot:2
End DoDot:1
+4 IF $ORDER(^PS(52.41,ORD,3,0))
Begin DoDot:1
+5 SET PRC=^PS(52.41,ORD,3,0)
SET T=0
Begin DoDot:2
+6 FOR
SET T=$ORDER(^PS(52.41,ORD,3,T))
IF 'T
QUIT
SET PRC(T)=^PS(52.41,ORD,3,T,0)
End DoDot:2
End DoDot:1
+7 QUIT
INS1 ;
+1 NEW INST,MIG,SG,JUNK,IEN,SINS1
+2 SET IEN=1
+3 SET INST=0
FOR
SET INST=$ORDER(^PS(52.41,ORD,"INS1",INST))
IF 'INST
QUIT
SET (MIG,PSONEW("SIG",INST))=^PS(52.41,ORD,"INS1",INST,0)
Begin DoDot:1
+4 FOR SG=1:1:$LENGTH(MIG," ")
SET IEN=IEN+1
SET $PIECE(JUNK("PSOPO",$JOB,IEN,0)," ",20)=" "
SET JUNK("PSOPO",$JOB,IEN,0)=$GET(JUNK("PSOPO",$JOB,IEN,0))_" "_$PIECE(MIG," ",SG)
End DoDot:1
+5 IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
IF $ORDER(^PS(52.41,ORD,"INS1",0))
Begin DoDot:1
+6 IF $GET(^PS(50.7,PSODRUG("OI"),"INS1"))]""
SET (X,PSONEW("SINS"))=^PS(50.7,PSODRUG("OI"),"INS1")
DO SSIG^PSOHELP
+7 IF $GET(SINS1)]""
SET PSONEW("SINS")=$EXTRACT(SINS1,2,250)
+8 SET IEN=IEN+1
SET JUNK("PSOPO",$JOB,IEN,0)=" Other Pat Instruct: "_$SELECT($GET(PSONEW("SINS"))]"":PSONEW("SINS"),1:"")
End DoDot:1
+9 QUIT
+10 ;
SIG ;
+1 SET SIG=0
SET PSOFINFL=1
FOR
SET SIG=$ORDER(^PS(52.41,ORD,"SIG",SIG))
IF 'SIG
QUIT
Begin DoDot:1
+2 SET SIG(SIG)=^PS(52.41,ORD,"SIG",SIG,0)
End DoDot:1
+3 DO EN^PSOFSIG(.PSONEW)
+4 IF $ORDER(SIG(0))
SET SIGOK=1
+5 FOR D=0:0
SET D=$ORDER(^PS(52.41,ORD,"INS1",D))
IF 'D
QUIT
Begin DoDot:1
+6 SET PSONEW("INS",D)=^PS(52.41,ORD,"INS1",D,0)
End DoDot:1
+7 QUIT
+8 ; Update activity or label log and return success flag
+9 ; Input: RX - IEN to Prescription File (52)
+10 ; TYPE - 0=Activity, 1=Label, 2=Reprint
+11 ; ARY - Holds data for log type
UPTLOG(DATA,RX,TYPE,ARY) ;EP
+1 NEW FDA,ERR,FN,IENS,USR
+2 SET IENS="+1,"_RX_","
+3 SET USR=$SELECT($GET(ARY("USER")):ARY("USER"),1:DUZ)
+4 SET DATA=0
+5 ;Activity Log
IF '$GET(TYPE)!($GET(TYPE)=2)
Begin DoDot:1
+6 SET FN=52.3
+7 SET FDA(FN,IENS,.01)=$$NOW^XLFDT()
+8 SET FDA(FN,IENS,.02)=$GET(ARY("REASON"))
+9 SET FDA(FN,IENS,.03)=USR
+10 SET FDA(FN,IENS,.04)=$GET(ARY("RX REF"))
+11 SET FDA(FN,IENS,.05)=$EXTRACT($GET(ARY("COM")),1,75)
+12 SET FDA(FN,IENS,9999999.01)=$GET(ARY("DEV"))
+13 SET FDA(FN,IENS,9999999.02)=$GET(ARY("TYPE"))
End DoDot:1
+14 ;Print Label Log
IF '$TEST
IF $GET(TYPE)=1
Begin DoDot:1
+15 SET FN=52.032
+16 SET FDA(FN,IENS,.01)=$$NOW^XLFDT()
+17 SET FDA(FN,IENS,1)=$GET(ARY("RX REF"))
+18 SET FDA(FN,IENS,2)=$GET(ARY("COM"))
+19 SET FDA(FN,IENS,3)=USR
+20 SET FDA(FN,IENS,5)=$GET(ARY("DEV"))
End DoDot:1
+21 DO UPDATE^DIE(,"FDA",,"ERR")
+22 IF '$DATA(ERR)
SET DATA=1
+23 IF '$TEST
SET DATA="0^Unable to update log"
+24 QUIT
+25 ;
+26 ; Log autofinish activity
+27 ; Input: OIEN - Order IEN
+28 ; SUC - Successful flag
+29 ; COM - Comment for unsuccessful
AFLOG(DATA,OIEN,SUC,COM) ;EP
+1 NEW FDA,ERR,FN
+2 IF '$GET(SUC)
IF $ORDER(^APSPAF("C",+$GET(OIEN),0))
QUIT
+3 SET IENS="+1,"
+4 SET DATA=0
+5 SET FN=9009033.92
+6 SET FDA(FN,IENS,.01)=$$NOW^XLFDT()
+7 SET FDA(FN,IENS,.02)=$GET(OIEN)
+8 SET FDA(FN,IENS,.03)=$GET(SUC)
+9 SET FDA(FN,IENS,.04)=$GET(COM)
+10 DO UPDATE^DIE(,"FDA",,"ERR")
+11 IF '$DATA(ERR)
SET DATA=1
+12 IF '$TEST
SET DATA="0^Unable to update log"
+13 QUIT
+14 ;
GETPRVI ; EP-Get provider instructions
+1 IF '$ORDER(PRC(0))!'$$GET^XPAR("DIV.`"_INSTIEN_"^SYS","APSP AUTO RX ADD PRV COMMENT")
QUIT
+2 NEW NI,NC
+3 SET PSOPRC=1
SET NI=0
FOR I=0:0
SET I=$ORDER(PSONEW("SIG",I))
IF 'I
QUIT
SET NI=I
+4 DO EXPPRC^PSOORFI4(.PRC)
+5 SET NC=0
FOR I=0:0
SET I=$ORDER(PRC(I))
IF 'I
QUIT
SET NC=NC+1
+6 IF NI'>1
IF NC=1
IF ($LENGTH($GET(PSONEW("SIG",NI)))+$LENGTH(PRC(1)))'>250
Begin DoDot:1
+7 SET PSONEW("SIG",1)=$GET(PSONEW("SIG",NI))_" "_PRC(1)
+8 IF $EXTRACT(PSONEW("SIG",1))=" "
SET PSONEW("SIG",1)=$EXTRACT(PSONEW("SIG",1),2,250)
SET PSONEW("INS")=PSONEW("SIG",1)
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 FOR I=0:0
SET I=$ORDER(PRC(I))
IF 'I
QUIT
SET NI=NI+1
SET (PSONEW("SIG",NI),PSONEW("INS",NI))=PRC(I)
+11 IF $EXTRACT(PSONEW("SIG",1))=" "
SET PSONEW("SIG",1)=$EXTRACT(PSONEW("SIG",1),2,250)
End DoDot:1
+12 DO EN^PSOFSIG(.PSONEW)
+13 QUIT
+14 ;
ADDPCSIG ;EP - Add provider comments to SIG
+1 NEW LP,LP1,SCNT
+2 SET SCNT=$ORDER(SIG($CHAR(1)),-1)
+3 SET LP=0
FOR
SET LP=$ORDER(PSONEW("SIG",LP))
IF 'LP
QUIT
Begin DoDot:1
+4 SET SCNT=SCNT+1
SET SIG(SCNT)=$GET(PSONEW("SIG",LP))
+5 SET SIG(SCNT)=$$UP^XLFSTR(SIG(SCNT))
End DoDot:1
+6 QUIT
DOSE(ORD) ;pending orders
+1 NEW DOSE,DOSE1,I,UNITS,ROUTE,DOENT
+2 SET DOENT=0
+3 FOR I=0:0
SET I=$ORDER(^PS(52.41,ORD,1,I))
IF 'I
QUIT
SET DOSE=$GET(^PS(52.41,ORD,1,I,1))
SET DOSE1=$GET(^(2))
Begin DoDot:1
+4 SET PSONEW("DOSE",I)=$PIECE(DOSE1,"^")
SET PSONEW("DOSE ORDERED",I)=$PIECE(DOSE1,"^",2)
SET PSONEW("UNITS",I)=$PIECE(DOSE,"^",9)
SET PSONEW("NOUN",I)=$PIECE(DOSE,"^",5)
+5 IF $PIECE(DOSE,"^",9)
SET UNITS=$PIECE(^PS(50.607,$PIECE(DOSE,"^",9),0),"^")
+6 SET PSONEW("VERB",I)=$PIECE(DOSE,"^",10)
SET PSONEW("ROUTE",I)=$PIECE(DOSE,"^",8)
+7 IF $PIECE(DOSE,"^",8)
SET ROUTE=$PIECE(^PS(51.2,$PIECE(DOSE,"^",8),0),"^")
+8 SET PSONEW("SCHEDULE",I)=$PIECE(DOSE,"^")
SET PSONEW("DURATION",I)=$PIECE(DOSE,"^",2)
+9 ;IHS/MSC/MGH - P1013
SET PSONEW("DURATION",I)=$SELECT($EXTRACT(PSONEW("DURATION",I),1)'?.N:$EXTRACT(PSONEW("DURATION",I),2,99)_$EXTRACT(PSONEW("DURATION",I),1),1:PSONEW("DURATION",I))
+10 ;S DOENT=$G(DOENT)+1 S PSONEW("CONJUNCTION",I)=$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="S":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"") ;IHSMSC/PLS - P1015
+11 SET DOENT=$GET(DOENT)+1
SET PSONEW("CONJUNCTION",I)=$PIECE(DOSE,"^",6)
End DoDot:1
+12 SET PSONEW("ENT")=DOENT
+13 QUIT
+14 ;Return list of pharmacies from APSP PHARMACY LIST
PHMLST(DATA,ZIP,RAD) ;EP
+1 NEW IEN,CNT,ZARY,ZC,PTYPE
+2 SET DATA=$NAME(^TMP("APSPOPHM",$JOB))
+3 KILL @DATA
+4 IF '$GET(ZIP)
QUIT
+5 DO GETZC(.ZARY,ZIP,RAD)
+6 SET ZC=""
SET CNT=0
FOR
SET ZC=$ORDER(ZARY(ZC))
IF '$LENGTH(ZC)
QUIT
Begin DoDot:1
+7 SET IEN=0
FOR
SET IEN=$ORDER(^APSPOPHM("ZIP",ZC,IEN))
IF 'IEN
QUIT
DO ADDPHM(IEN,ZARY(ZC))
End DoDot:1
+8 IF $$GET^XPAR("ALL","APSP SS PHARMACY MAILORDER")
Begin DoDot:1
+9 SET PTYPE=1
+10 SET LP=0
+11 FOR
SET LP=$ORDER(^APSPOPHM(LP))
IF 'LP
QUIT
Begin DoDot:2
+12 IF $$SPECID^APSPFNC5(LP,PTYPE,1)
DO ADDPHM(LP,99)
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;Return list of pharmacies from IEN list
PHMLST2(DATA,IEN) ;EP
+1 NEW CNT
+2 SET DATA=$NAME(^TMP("APSPOPHM",$JOB))
+3 KILL @DATA
+4 IF $GET(IEN)
SET IEN(-1)=IEN
+5 SET IEN=""
SET CNT=0
+6 FOR
SET IEN=$ORDER(IEN(IEN))
IF IEN=""
QUIT
DO ADDPHM(+IEN(IEN),,0)
+7 QUIT
ADDPHM(IEN,DIST,NEWRX) ;
+1 NEW N0,N1,N2,N7,N8,I,ID,SPEC,SVL
+2 SET SPEC=""
+3 SET NEWRX=$GET(NEWRX,1)
+4 SET N0=$GET(^APSPOPHM(IEN,0))
SET N1=$GET(^(1))
SET N2=$GET(^(2))
SET N7=$GET(^(7))
+5 IF '$LENGTH(N0)
QUIT
+6 SET SVL=$PIECE(N0,U,5)
+7 ;P12 Only return NEWRX service level
IF NEWRX
IF '(SVL#2)
QUIT
+8 IF N7
IF DT<N7
QUIT
+9 IF $PIECE(N7,U,2)
IF DT>$PIECE(N7,U,2)
QUIT
+10 SET CNT=CNT+1
SET DIST=$GET(DIST)
+11 ;IHS/MSC/MGH Update for specialty IDs
+12 IF $DATA(^APSPOPHM(IEN,8))
Begin DoDot:1
+13 SET I=0
FOR
SET I=$ORDER(^APSPOPHM(IEN,8,I))
IF I=""
QUIT
Begin DoDot:2
+14 SET ID=$GET(^APSPOPHM(IEN,8,I,0))
+15 SET ID=$SELECT(ID=1:"MAIL ORDER",ID=2:"FAX",ID=8:"RETAIL",ID=16:"SPECIALTY",ID=32:"LONG-TERM CARE",ID=64:"24 HOUR",1:"")
+16 IF ID'=""
Begin DoDot:3
+17 IF SPEC=""
SET SPEC=ID
+18 IF '$TEST
SET SPEC=SPEC_","_ID
End DoDot:3
End DoDot:2
End DoDot:1
+19 ; IEN^StoreName^Address1 Address2^City^State^Zip^PFAX^PPhone^Distance^Specialty
+20 SET @DATA@(+DIST,CNT)=IEN_U_$PIECE(N0,U,10)_U_$PIECE(N1,U)_" "_$PIECE(N1,U,2)_U_$PIECE(N1,U,3)_U_$PIECE(N1,U,4)_U_$PIECE(N1,U,5)_U_$PIECE(N2,U,2)_U_$PIECE(N2,U)_U_$FNUMBER(DIST,"",2)_U_SPEC
+21 QUIT
+22 ; Return array of zipcodes for given zipcode
+23 ; Input: ARY - return array - pass by reference
+24 ; ZIP - 5 DIGIT ZIP CODE
+25 ; R - radius
+26 ; Output: ARY(ZC)=radius
+27 ;
GETZC(ARY,ZIP,R) ;EP
+1 NEW ZIEN,ZC,D,RAD
+2 KILL ARY
+3 SET ZIEN=$ORDER(^APSPZCPX("B",ZIP,0))
IF 'ZIEN
QUIT
Begin DoDot:1
+4 SET RAD=""
FOR
SET RAD=$ORDER(^APSPZCPX(ZIEN,1,"B",RAD))
IF RAD=""!(RAD>R)
QUIT
Begin DoDot:2
+5 SET ZC=0
FOR
SET ZC=$ORDER(^APSPZCPX(ZIEN,1,"B",RAD,ZC))
IF 'ZC
QUIT
Begin DoDot:3
+6 SET ARY($PIECE(^APSPZCPX(ZC,0),U))=RAD
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT
+8 ; Returns ability of user to e-prescribe
+9 ; Input: USR - IEN to New Person File
+10 ; Output: 0 = e-Prescribing is not available to user
+11 ; 1 = e-Prescribing is available to user
ERXUSER(DATA,USR) ; EP
+1 SET DATA=1
+2 IF $GET(USR)
Begin DoDot:1
+3 SET DATA=''$LENGTH($$SPI^APSPES1(USR))
+4 IF 'DATA
SET DATA=+$$GET^XPAR($$ENT^CIAVMRPC("APSP AUTO RX ELECTRONIC",.ENT,USR),"APSP AUTO RX ELECTRONIC")
End DoDot:1
+5 QUIT
+6 ; Returns availablity of Orderable Item to be e-prescribed
+7 ; Input: OIIEN - Orderable Item IEN
+8 ; SCH - String of schedules - defaults to 2345
ERXOI(DATA,OIIEN,SCH) ; EP
+1 NEW PSOI
+2 SET DATA=1
SET SCH=$GET(SCH,"2345")
+3 IF $GET(OIIEN)
Begin DoDot:1
+4 ; Pharmacy Orderable Item IEN
SET PSOI=+$PIECE($GET(^ORD(101.43,+OIIEN,0)),U,2)
+5 SET DIEN=0
FOR
SET DIEN=$ORDER(^PSDRUG("ASP",PSOI,DIEN))
IF 'DIEN
QUIT
Begin DoDot:2
+6 SET DATA='$$ISSCH(DIEN,SCH)
End DoDot:2
IF 'DATA
QUIT
End DoDot:1
+7 QUIT
+8 ; Returns result of DEA Special Handling Comparison
+9 ; Input : ORD = Order ID
+10 ; CLS = Drug class
DEACLS(DATA,ORD,CLS) ; EP -
+1 NEW PSOI,OIIEN
+2 SET OIIEN=$$VALUE^ORCSAVE2(+ORD,"ORDERABLE")
+3 SET DATA=0
+4 IF $GET(OIIEN)
Begin DoDot:1
+5 ; Pharmacy Orderable Item IEN
SET PSOI=+$PIECE($GET(^ORD(101.43,+OIIEN,0)),U,2)
+6 SET DIEN=0
FOR
SET DIEN=$ORDER(^PSDRUG("ASP",PSOI,DIEN))
IF 'DIEN
QUIT
Begin DoDot:2
+7 SET DATA=$$ISSCH(DIEN,CLS)
End DoDot:2
IF DATA
QUIT
End DoDot:1
+8 QUIT
+9 ; Check for schedule drugs
ISSCH(DRUG,SCH) ;PEP - Returns boolean value
+1 NEW DS,RES
+2 SET RES=0
+3 SET DS=+$PIECE(^PSDRUG(DRUG,0),U,3)
+4 SET RES=SCH[DS
+5 QUIT RES
+6 ; Notify user of autofinish failure
+7 ; Input: USR - User IEN
+8 ; DFN - Patient IEN
+9 ; ORIEN - Order IEN
+10 ; MSG - Message text
+11 ; ALRTD - Alert data
NOTIF(USR,DFN,ORIEN,MSG,ALRTD) ;EP -
+1 NEW XQA,XQAID,XQADATA,XQAMSG
+2 SET XQA(USR)=""
+3 SET XQAMSG="Autofinish Failure:"_$GET(MSG)
+4 SET XQAID="OR"_","_DFN_","_99003
+5 IF $GET(ORIEN)
SET XQADATA=ORIEN_"@"_$GET(ALRTD)
+6 DO SETUP^XQALERT
+7 QUIT
+8 ; Check for renewed prescription
+9 ; Input: RXIEN- IEN to File 52
CHKRNW(RXIEN) ;
+1 ;Check Placer ID of RXIEN
+2 ; Check Replaced Order # field value
+3 ; Check Status of Replaced Order order
+4 ; If RENEWED then set:
+5 ; - Activity Log - RENEWED
+6 IF '$GET(RXIEN)
QUIT
+7 ;,PSORENW,PSONEW
NEW PLACER,ORGIEN,RENEWED,ORGPKGID,ORXNUM
+8 NEW REA,DA,MSG,PSCAN
+9 SET PLACER=$$GET1^DIQ(52,RXIEN,39.3)
+10 IF 'PLACER
QUIT
+11 SET ORGIEN=$$GET1^DIQ(100,PLACER,9,"I")
+12 ;No renewed order
IF 'ORGIEN
QUIT
+13 SET RENEWED=$$GET1^DIQ(100,ORGIEN,5,"I")=15
+14 IF 'RENEWED
QUIT
+15 SET ORGPKGID=+$$GET1^DIQ(100,ORGIEN,33,"I")
+16 IF 'ORGPKGID
QUIT
+17 SET ORXNUM=$$GET1^DIQ(52,ORGPKGID,.01)
+18 SET REA="C"
SET DA=ORGPKGID
+19 SET MSG="Renewed/Updated from RPMS EHR"
+20 SET PSCAN(ORXNUM)=DA_"^C"
+21 DO CAN^PSOCAN
+22 IF RNWORDER
Begin DoDot:1
+23 DO SETDATA(RNWORDER,52,"39.5///"_"`"_RXIEN)
+24 DO SETDATA(RXIEN,52,"39.4///"_"`"_RNWORDER)
End DoDot:1
+25 QUIT
+26 ;
SETDATA(DA,DIE,DR) ;
+1 DO ^DIE
+2 QUIT
