APSPPCC ;IHS/CIA/DKM/PLS - PCC Hook for Pharmacy Package ;22-Sep-2014 14:55;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1004,1006,1007,1008,1009,1010,1013,1015,1017,1018**;Sep 23, 2004;Build 21
; EP - Called by event protocol.
; DATA = Event message. May either be a global reference or
; a local array passed by reference.
; REPROC = If this is a reprocessed message, this should contain
; the index of the message in the XTMP global.
; Modified - IHS/MSC/PLS - 02/04/08 - Line POV - changed v68.1 to primary
; 02/05/08 - API PRVNARR modified
; 01/27/09 - LOCADJ+4
; 01/28/09 - Checks for SUSPENSE status
; 08/25/10 - DOIT+40
; 02/10/11 - Added support of POV for Suspense
; 01/28/14 - Line REFPRV+3
; 06/04/14 - Added support of adding POV to visits
EN(DATA,REPROC) ;EP
N MSG
I $D(DATA)=1 M MSG=@DATA
E M MSG=DATA
S MSG=$S($G(REPROC):REPROC,1:-1)
;I $$QUEUE^CIAUTSK("TASK^APSPPCC","PCC VMED FILER",,"MSG^MSG(")
D TASK
Q
; Taskman entry point
TASK ;EP
N SEG,LP,DL1,DL2,IEN
S ZTREQ="@"
S LP=0
S SEG=$$SEG("MSH",.LP)
Q:'LP
S DL1=$E(SEG,4),DL2=$E(SEG,5)
Q:$P(SEG,DL1,3)'="PHARMACY"
S SEG=$$SEG("PID",.LP)
Q:'LP
Q:'$P(SEG,DL1,4)
S SEG=$$SEG("ORC",.LP)
Q:'LP
S IEN=$P($P(SEG,DL1,4),U)
I IEN?1.N1"N" D EN^APSPPCC2(IEN,.MSG) ;IHS/MSC/PLS 10/29/07 - Outside Meds
Q:IEN'=+IEN
D LOG("MSG",.MSG)
K:$$PROCESS(IEN,,MSG,1)<0 ZTREQ
Q
; EP - Process a script
; IEN = IEN of prescription
; REF = Refill # (0=original fill,>0=refill,missing=last)
; MSG = Message log IEN
; BUL = If nonzero, a bulletin is fired on error
PROCESS(IEN,REF,MSG,BUL) ;EP
N PRV,SIG,RX0,RX2,RX3,PCC,LOC,DAT,DIV,INS,RTS,PHM,QTY,DAY,CAN,DFN,OPV
N VMED,VM0,VSTR,VSIT,ERR,ACT,COM,RXID,PLOC,PRI,POV,DRG,STA,RF0,LFN,X
N DEFOLOC,VSVCCAT
S ERR="",MSG=$G(MSG),BUL=$G(BUL)
L +^APSPPCC(IEN):5
I D
.D DOIT
.L -^APSPPCC(IEN)
E S ERR="-1^Timeout while trying to lock record."
D:ERR LOG("ERR",.MSG)
D:ERR<0 BUL(IEN,.DFN,.MSG,ERR):BUL
;IHS exemption approved on 3/29/2007
Q:$Q ERR
Q
DOIT ;EP
D LOG($NA(^PSRX(IEN)),.MSG)
S RX0=$G(^PSRX(IEN,0)),RX2=$G(^(2)),RX3=$G(^(3)),STA=+$G(^("STA")),LFN=+$O(^(1,$C(1)),-1)
S RXID=$P(RX0,U)
S DFN=$P(RX0,U,2)
;IHS/CIA/PLS - 05/23/06 - Commented out next line and added the line after.
;K:STA'<10 ^PS(55,DFN,"P","CP",IEN)
; Chronic Med flag is cleared if status is: DISCONTINUED, DELETED, DISCONTINUED BY PROVIDER or
; DISCONTINUED (EDIT)
D:STA>11&(STA<16) KILLOCM^PSORN52(IEN)
I STA=13,LFN S ERR="1^Prescription logically deleted." Q ;Ignore if deleted with refills remaining
S CAN=$P(RX3,U,5)
I STA=14,'CAN S CAN=$P($G(^OR(100,+$P($G(^PSRX(IEN,"OR1")),U,2),6)),U,3)
S DRG=$P(RX0,U,6) ;Drug
S SIG=$P(RX0,U,10) ;SIG
S LOC=$P(RX0,U,5) ;Clinic (File 44 IEN)
S:'$L(SIG) SIG=$P($G(^PSRX(IEN,"SIG")),U)
I '$L(SIG) D
.F X=0:0 S X=$O(^PSRX(IEN,"SIG1",X)) Q:'X S SIG=SIG_$S($L(SIG):" ",1:"")_^(X,0) Q:$L(SIG)>144
S:'$D(REF) REF=LFN
S RF0=$S(REF:$G(^PSRX(IEN,1,REF,0)),1:RX0)
S VMED=+$S(REF:$G(^PSRX(IEN,1,REF,999999911)),1:$G(^PSRX(IEN,999999911)))
S DAT=+$S(REF:$P(RF0,U),1:$P(RX2,U,2))
;I STA=3,'DAT S DAT=DT ; Substitute Today's Date if Fill Date null.
;IHS/MSC/PLS - 01/28/09 - Added check for suspense status
I (STA=3!(STA=5)),'DAT S DAT=DT ; Substitute Today's Date if Fill Date null.
I 'DAT S ERR="1^Not released." Q
I DAT>DT,'VMED S ERR="1^Future Fill Date - Suspense" Q
I REF D ; Use Refill Date for refills
.I DAT>DT S DAT=+$P(RF0,U,19) ; Use Dispense date if Refill Date>Today
I 'DAT S ERR="1^No date associated with fill."
S:DAT#1=0 DAT=DAT+.12
S DIV=+$P($S(REF:RF0,1:RX2),U,9),INS=$$INS(DIV)
I 'INS S ERR="1^Hook disabled for division." Q
S DEFOLOC=$P($G(^APSPCTRL(DIV,1)),U,2)
S:'DEFOLOC DEFOLOC=INS
S RTS=$S(REF:$P(RF0,U,16),1:$P(RX2,U,15))\1
S COM=$S(RTS:"RETURNED TO STOCK",1:"@")
S VMED=+$S(REF:$G(^PSRX(IEN,1,REF,999999911)),1:$G(^PSRX(IEN,999999911)))
;S ACT=$S(STA=13:"-",STA=16:"-",STA=3:"-",VMED:"",1:"+")
;IHS/MSC/PLS - 01/28/09 - Added check for suspense status
S ACT=$S(STA=13:"-",STA=16:"-",STA=3:"-",STA=5:"-",VMED:"",1:"+")
I 'VMED,ACT="-" Q
;IHS/MSC/PLS - 02/10/2011 - removed restriction for refill on POV process
; Process Paperless Refills
;I +$$GET1^DIQ(9009033,+$G(DIV),315,"I") D
;.;IHS/MSC/PLS - 08/25/10 - Logic changed to obtain cached POV from Parameter
;.;Q:'$L($G(^XTMP("APSPPCC.VPOV",+IEN,+REF)))
;.Q:'$D(^PSRX(IEN,1,REF)) ; Refill check
;.;S POV=$G(^XTMP("APSPPCC.VPOV",IEN,REF))
;.S POV=$TR($$GET^XPAR("SYS","APSP POV CACHE",+IEN_","_+REF),"~",U)
;.Q:'$L(POV)
;.S DAT=$P(DAT,".")_".13"
;.;K ^XTMP("APSPPCC.VPOV",IEN,REF)
; Check for cached POV
;IHS/MSC/PLS - 07/16/13 - POV no longer captured
;IHS/MSC/PLS - 06/04/14 - POV is being used again as a hardcoded set in APSPPCC1
S POV=$TR($$GET^XPAR("SYS","APSP POV CACHE",+IEN_","_+REF),"~",U)
;S POV=""
; Refills or suspended prescriptions will be set to 1300 unless the
; suspended prescription is an original dispensed on the day of release.
;I $L(POV),$$GET1^DIQ(9009033,PSOSITE,405,"I") D ;IHS/MSC/PLS - 10/28/11 - Capture POV for all prescriptions
I $L(POV),$$GET1^DIQ(9009033,$G(PSOSITE),405,"I") D ;IHS/MSC/PLS - 01/07/13 - Wrap with $G
.S DAT=DAT ;S DAT=$P(DAT,".")_".13"
;E I $L(POV),$P(RX0,U,13)'=$P(DAT,".") D ; if issue date<>fill date
;.S DAT=$P(DAT,".")_".13"
E D
.D:$L(POV)&(ACT'="-") DEL^XPAR("SYS","APSP POV CACHE",+IEN_","_+REF)
.K POV
; Provider is set to Clerk if Paperless Refill otherwise to Ordering Provider
;S (OPV,PRV)=$S($D(POV):$$NPF($P(RF0,U,7)),1:$$NPF(+$P(RX0,U,4)))
;IHS/CIA/PLS - 10/07/05 - Changed following line to look at clerk if paperless refill, refill provider if regular refill or prescription provider
;S PRV=$S($D(POV):$$NPF($P(RF0,U,7)),1:$$NPF(+$P(RX0,U,4)))
;IHS/MSC/PLS - 10/23/07 - Changed following line to add support for requesting refill provider
;S PRV=$S($D(POV):$$NPF($P(RF0,U,7)),REF:$$NPF($P(RF0,U,17)),1:$$NPF(+$P(RX0,U,4)))
S PRV=$S($D(POV):$S(REF:$$NPF($P(RF0,U,7)),1:$$NPF(+$P($G(^PSRX(IEN,"OR1")),U,5))),REF:$$REFPRV(IEN,REF),1:$$NPF(+$P(RX0,U,4))) ;p1010
S OPV=$S(REF:$$NPF($P(RF0,U,17)),1:$$NPF(+$P(RX0,U,4))) ;Provider
S PHM=$$NPF(+$P(RX2,U,3)) ;Pharmacist
S:REF PHM=$$NPF($P(RF0,U,7)) ;Clerk Code
S:'PHM PHM=$$NPF(+$P($G(^PSRX(IEN,"OR1")),U,5)) ;Finishing Person
S:'PHM PHM=$$NPF(+$P(RX0,U,16)) ;Entered By
S QTY=$P(RF0,U,$S(REF:4,1:7))
S DAY=$P(RF0,U,$S(REF:10,1:8))
;S VMED=+$S(REF:$G(^PSRX(IEN,1,REF,999999911)),1:$G(^PSRX(IEN,999999911)))
;;S ACT=$S(STA=13:"-",STA=16:"-",STA=3:"-",VMED:"",1:"+")
;;IHS/MSC/PLS - 01/28/09 - Added check for suspense status
;S ACT=$S(STA=13:"-",STA=16:"-",STA=3:"-",STA=5:"-",VMED:"",1:"+")
;I 'VMED,ACT="-" Q
S VM0=$S(VMED:$G(^AUPNVMED(VMED,0)),1:"")
S VSIT=$P(VM0,U,3)
S VSVCCAT="A"
;IHS/CIA/PLS - 10/07/05 - Changed to pass clinic (if defined) or zero for ancillary
;S LOC=$S($D(POV):$O(^DIC(40.7,"C",39,0)),1:0) ; Set location to pharmacy stop code if Paperless refill
;Old format = VSTR format = zero or Clinic Stop Code; Date/Time of Visit;Visit Category
S LOC=$$LOCADJ(LOC,IEN,RXID) ; IHS/CIA/PLS - 12/30/05 - Call to adjust the hospital location for REFILL and RENEWED orders
S:$D(POV) LOC=0
; New VSTR format = Hospital Location IEN; Date/Time of Visit;Visit Category
I $P($G(^PSRX(IEN,999999921)),U,4) D ; Electronic Pharmacy
.N EPHARM
.S EPHARM=$$GET1^DIQ(9009033.9,$$GET1^DIQ(52,IEN,9999999.24,"I"),.01)
.S VSIT=$S('VSIT:";"_DEFOLOC_";"_EPHARM,1:VSIT)
.S VSVCCAT="E"
S VSTR=LOC_";"_DAT_";"_VSVCCAT_";"_VSIT ; Location is either a pointer to clinic stop code or a zero
;S (PRV,PHM,PRI)=0
I $D(POV) D
.S PRI=1,PHM=0
.S X=$$VSTR2VIS^APSPPCCV(DFN,.VSTR,1,PRV,DIV,1) ;Find or create a visit using clerk code
E D
.S X=$$VSTR2VIS^APSPPCCV(DFN,.VSTR,1,PRV,DIV,0) ;Find or create a visit using ordering provider
.;I X'>0!(+VSTR=PLOC) S LOC=PLOC,$P(VSTR,";")=PLOC,PRV=0,PHM=0,PRI=1
.I X'>0 S PRV=0,PHM=0,PRI=1
.E S (PRV,PHM,PRI)=0
D ADD("HDR^^^"_VSTR)
D ADD("VST^PT^"_DFN)
D ADD("VST^DT^"_DAT)
D:$D(POV)&PRV ADD("PRV^"_PRV_"^^^^"_PRI)
D:PHM ADD("PRV^"_PHM_"^^^^0")
POV I $D(POV) D
.;D:POV'="" ADD("POV^"_$P(POV,U)_"^^"_$P(POV,U,2)_"^0^2") ;IHS/MSC/PLS - 02/04/2008 - Changed to secondary
.;D:POV'="" ADD("POV^"_$P(POV,U)_"^^"_$P(POV,U,2)_U_$S(REF:0,1:1)_U_$S(REF:2,1:1)) ;IHS/MSC/PLS - 04/21/2011
.;D:REF ADD("POV^"_"V68.1"_"^^"_$$PRVNARR("MEDICATION REFILL")_"^1^2") ;IHS/MSC/PLS - 02/04/2008 - Changed to primary
.D:POV'="" ADD("POV^"_$P(POV,U)_"^^^1^"_$S(REF:2,1:1)) ;IHS/MSC/PLS - 09/22/2014
.;IHS/MSC/PLS - 08/25/2010 - remove the cached data
.Q:ACT="-" ;Leave in cache
.D DEL^XPAR("SYS","APSP POV CACHE",+IEN_","_+REF)
I VM0,DRG'=+VM0 D ADD("RX-^"_+VM0_U_VMED_U_IEN_U_REF) S ACT="+"
D ADD("RX"_ACT_U_DRG_U_VMED_U_IEN_U_REF_U_$S(OPV:OPV,1:"")_U_QTY_U_DAY_U_$S(RTS:RTS,1:CAN)_U_RXID)
D:$L(COM) ADD("COM^1^"_COM)
D ADD("SIG^1^"_$S($L(SIG)<146:SIG,1:$E(SIG,1,144)_"~"))
D LOG("PCC",.MSG)
D SAVE^APSPPCCV(.ERR,.PCC)
Q
; Add to PCC array
ADD(X) S PCC=$G(PCC)+1,PCC(PCC)=X
Q
; Adjust file 200 pointer if file 16 conversion not done
NPF(IEN) Q +$S('$D(^VA(200,+IEN,0)):0,$P($G(^AUTTSITE(1,0)),U,22):IEN,1:$P(^VA(200,+IEN,0),U,16))
; Return institution if PCC capture enabled for division
INS(DIV) Q $S($P($G(^APSPCTRL(+DIV,0)),U,15)="Y":+$G(^PS(59,+DIV,"INI")),1:0)
; Return specified segment, starting at line LP
SEG(TYP,LP) ;
F S LP=$O(MSG(LP)) Q:'LP Q:$E(MSG(LP),1,$L(TYP))=TYP
Q $S(LP:MSG(LP),1:"")
; Send a bulletin on error
BUL(IEN,DFN,MSG,ERR) ;
N XMB,XMTEXT,XMY,XMDUZ,XMDT,XMYBLOB,XMZ
S XMB="APSP LINK FAIL VMED"
S XMB(1)=$G(IEN,"UNKNOWN")
S XMB(2)=$P($G(^DPT(DFN,0)),U)
S XMB(3)=$G(MSG,"UNKNOWN")
S XMB(4)=$$FMTE^XLFDT(DT)
S XMB(5)=$P(ERR,U,2)
S XMDUZ=.5
D ^XMB
Q
; Log data
LOG(ARY,CNT) ;
Q:'$G(CNT)
Q:'$$GET^XPAR("ALL","APSPPCC LOG MESSAGES")
N SUB,NMSP
S SUB="APSPPCC",NMSP=$TR($P(ARY,"("),U)
L +^XTMP(SUB):2
S ^XTMP(SUB,0)=$$FMADD^XLFDT(DT,7)_U_$$DT^XLFDT
S:CNT<0 CNT=1+$O(^XTMP(SUB,""),-1)
K ^XTMP(SUB,CNT,NMSP)
M ^XTMP(SUB,CNT,NMSP)=@ARY
L -^XTMP(SUB)
Q
; Return Provider Narrative IEN
PRVNARR(TXT) ; EP
N IEN,FDA,IENS,ERR
Q:'$L(TXT) ""
S IEN=$O(^AUTNPOV("B",$E(TXT,1,30),0)) ; IHS/MSC/PLS - 02/05/08 - Changed lookup to 30 characters
I 'IEN D
.S FDA(9999999.27,"+1,",.01)=$E(TXT,1,80) ; IHS/MSC/PLS - 02/05/08 - Changed set to 80 characters
.D UPDATE^DIE("","FDA","IENS","ERR")
.I $G(ERR) S IEN=""
.E S IEN=$G(IENS(1))
Q IEN
; Return Inpatient Location IEN or Zero
; VAINDT contains inpatient admission date or defaults to today
INPAT(DFN,VAINDT) ;
N RET,VAIN
D INP^VADPT
S RET=+$G(VAIN(4))
Q RET
; Return adjusted Hospital Location IEN
; The visit location will be returned as zero using the following rules:
; 1) Refill orders - Orders processed using options other than PSO LMOE FINISH
; 2) Renew orders - Orders processed using options other than PSO LMOE FINISH
;
LOCADJ(LOC,RXIEN,RXN) ;EP
I $G(PSOFROM)="REFILL",$G(XQY0)'["PSO LMOE FINISH" S LOC=0
I $G(PSOFROM)="NEW",RXN?.N1.U,$G(XQY0)'["PSO LMOE FINISH" S LOC=0
; IHS/MSC/PLS - 01/27/2009 - If new prescription and Fill Date <> Issue Date
I $G(PSOFROM)="NEW",($P($G(^PSRX(RXIEN,2)),U,2)'=$P($G(^PSRX(RXIEN,0)),U,13)) S LOC=0
Q LOC
; IHS/MSC/PLS - 10/24/07
REFPRV(RX,REF) ;EP
N RES,PRV,RPRV
S PRV=$P(^PSRX(RX,1,REF,0),U,17)
S RPRV=$P($G(^PSRX(RX,1,REF,9999999)),U) ;IHS/MSC/PLS - 01/28/14 added $G
S RES=$S(RPRV:RPRV,1:PRV)
Q RES
APSPPCC ;IHS/CIA/DKM/PLS - PCC Hook for Pharmacy Package ;22-Sep-2014 14:55;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1004,1006,1007,1008,1009,1010,1013,1015,1017,1018**;Sep 23, 2004;Build 21
+2 ; EP - Called by event protocol.
+3 ; DATA = Event message. May either be a global reference or
+4 ; a local array passed by reference.
+5 ; REPROC = If this is a reprocessed message, this should contain
+6 ; the index of the message in the XTMP global.
+7 ; Modified - IHS/MSC/PLS - 02/04/08 - Line POV - changed v68.1 to primary
+8 ; 02/05/08 - API PRVNARR modified
+9 ; 01/27/09 - LOCADJ+4
+10 ; 01/28/09 - Checks for SUSPENSE status
+11 ; 08/25/10 - DOIT+40
+12 ; 02/10/11 - Added support of POV for Suspense
+13 ; 01/28/14 - Line REFPRV+3
+14 ; 06/04/14 - Added support of adding POV to visits
EN(DATA,REPROC) ;EP
+1 NEW MSG
+2 IF $DATA(DATA)=1
MERGE MSG=@DATA
+3 IF '$TEST
MERGE MSG=DATA
+4 SET MSG=$SELECT($GET(REPROC):REPROC,1:-1)
+5 ;I $$QUEUE^CIAUTSK("TASK^APSPPCC","PCC VMED FILER",,"MSG^MSG(")
+6 DO TASK
+7 QUIT
+8 ; Taskman entry point
TASK ;EP
+1 NEW SEG,LP,DL1,DL2,IEN
+2 SET ZTREQ="@"
+3 SET LP=0
+4 SET SEG=$$SEG("MSH",.LP)
+5 IF 'LP
QUIT
+6 SET DL1=$EXTRACT(SEG,4)
SET DL2=$EXTRACT(SEG,5)
+7 IF $PIECE(SEG,DL1,3)'="PHARMACY"
QUIT
+8 SET SEG=$$SEG("PID",.LP)
+9 IF 'LP
QUIT
+10 IF '$PIECE(SEG,DL1,4)
QUIT
+11 SET SEG=$$SEG("ORC",.LP)
+12 IF 'LP
QUIT
+13 SET IEN=$PIECE($PIECE(SEG,DL1,4),U)
+14 ;IHS/MSC/PLS 10/29/07 - Outside Meds
IF IEN?1.N1"N"
DO EN^APSPPCC2(IEN,.MSG)
+15 IF IEN'=+IEN
QUIT
+16 DO LOG("MSG",.MSG)
+17 IF $$PROCESS(IEN,,MSG,1)<0
KILL ZTREQ
+18 QUIT
+19 ; EP - Process a script
+20 ; IEN = IEN of prescription
+21 ; REF = Refill # (0=original fill,>0=refill,missing=last)
+22 ; MSG = Message log IEN
+23 ; BUL = If nonzero, a bulletin is fired on error
PROCESS(IEN,REF,MSG,BUL) ;EP
+1 NEW PRV,SIG,RX0,RX2,RX3,PCC,LOC,DAT,DIV,INS,RTS,PHM,QTY,DAY,CAN,DFN,OPV
+2 NEW VMED,VM0,VSTR,VSIT,ERR,ACT,COM,RXID,PLOC,PRI,POV,DRG,STA,RF0,LFN,X
+3 NEW DEFOLOC,VSVCCAT
+4 SET ERR=""
SET MSG=$GET(MSG)
SET BUL=$GET(BUL)
+5 LOCK +^APSPPCC(IEN):5
+6 IF $TEST
Begin DoDot:1
+7 DO DOIT
+8 LOCK -^APSPPCC(IEN)
End DoDot:1
+9 IF '$TEST
SET ERR="-1^Timeout while trying to lock record."
+10 IF ERR
DO LOG("ERR",.MSG)
+11 IF ERR<0
IF BUL
DO BUL(IEN,.DFN,.MSG,ERR)
+12 ;IHS exemption approved on 3/29/2007
+13 IF $QUIT
QUIT ERR
+14 QUIT
DOIT ;EP
+1 DO LOG($NAME(^PSRX(IEN)),.MSG)
+2 SET RX0=$GET(^PSRX(IEN,0))
SET RX2=$GET(^(2))
SET RX3=$GET(^(3))
SET STA=+$GET(^("STA"))
SET LFN=+$ORDER(^(1,$CHAR(1)),-1)
+3 SET RXID=$PIECE(RX0,U)
+4 SET DFN=$PIECE(RX0,U,2)
+5 ;IHS/CIA/PLS - 05/23/06 - Commented out next line and added the line after.
+6 ;K:STA'<10 ^PS(55,DFN,"P","CP",IEN)
+7 ; Chronic Med flag is cleared if status is: DISCONTINUED, DELETED, DISCONTINUED BY PROVIDER or
+8 ; DISCONTINUED (EDIT)
+9 IF STA>11&(STA<16)
DO KILLOCM^PSORN52(IEN)
+10 ;Ignore if deleted with refills remaining
IF STA=13
IF LFN
SET ERR="1^Prescription logically deleted."
QUIT
+11 SET CAN=$PIECE(RX3,U,5)
+12 IF STA=14
IF 'CAN
SET CAN=$PIECE($GET(^OR(100,+$PIECE($GET(^PSRX(IEN,"OR1")),U,2),6)),U,3)
+13 ;Drug
SET DRG=$PIECE(RX0,U,6)
+14 ;SIG
SET SIG=$PIECE(RX0,U,10)
+15 ;Clinic (File 44 IEN)
SET LOC=$PIECE(RX0,U,5)
+16 IF '$LENGTH(SIG)
SET SIG=$PIECE($GET(^PSRX(IEN,"SIG")),U)
+17 IF '$LENGTH(SIG)
Begin DoDot:1
+18 FOR X=0:0
SET X=$ORDER(^PSRX(IEN,"SIG1",X))
IF 'X
QUIT
SET SIG=SIG_$SELECT($LENGTH(SIG):" ",1:"")_^(X,0)
IF $LENGTH(SIG)>144
QUIT
End DoDot:1
+19 IF '$DATA(REF)
SET REF=LFN
+20 SET RF0=$SELECT(REF:$GET(^PSRX(IEN,1,REF,0)),1:RX0)
+21 SET VMED=+$SELECT(REF:$GET(^PSRX(IEN,1,REF,999999911)),1:$GET(^PSRX(IEN,999999911)))
+22 SET DAT=+$SELECT(REF:$PIECE(RF0,U),1:$PIECE(RX2,U,2))
+23 ;I STA=3,'DAT S DAT=DT ; Substitute Today's Date if Fill Date null.
+24 ;IHS/MSC/PLS - 01/28/09 - Added check for suspense status
+25 ; Substitute Today's Date if Fill Date null.
IF (STA=3!(STA=5))
IF 'DAT
SET DAT=DT
+26 IF 'DAT
SET ERR="1^Not released."
QUIT
+27 IF DAT>DT
IF 'VMED
SET ERR="1^Future Fill Date - Suspense"
QUIT
+28 ; Use Refill Date for refills
IF REF
Begin DoDot:1
+29 ; Use Dispense date if Refill Date>Today
IF DAT>DT
SET DAT=+$PIECE(RF0,U,19)
End DoDot:1
+30 IF 'DAT
SET ERR="1^No date associated with fill."
+31 IF DAT#1=0
SET DAT=DAT+.12
+32 SET DIV=+$PIECE($SELECT(REF:RF0,1:RX2),U,9)
SET INS=$$INS(DIV)
+33 IF 'INS
SET ERR="1^Hook disabled for division."
QUIT
+34 SET DEFOLOC=$PIECE($GET(^APSPCTRL(DIV,1)),U,2)
+35 IF 'DEFOLOC
SET DEFOLOC=INS
+36 SET RTS=$SELECT(REF:$PIECE(RF0,U,16),1:$PIECE(RX2,U,15))\1
+37 SET COM=$SELECT(RTS:"RETURNED TO STOCK",1:"@")
+38 SET VMED=+$SELECT(REF:$GET(^PSRX(IEN,1,REF,999999911)),1:$GET(^PSRX(IEN,999999911)))
+39 ;S ACT=$S(STA=13:"-",STA=16:"-",STA=3:"-",VMED:"",1:"+")
+40 ;IHS/MSC/PLS - 01/28/09 - Added check for suspense status
+41 SET ACT=$SELECT(STA=13:"-",STA=16:"-",STA=3:"-",STA=5:"-",VMED:"",1:"+")
+42 IF 'VMED
IF ACT="-"
QUIT
+43 ;IHS/MSC/PLS - 02/10/2011 - removed restriction for refill on POV process
+44 ; Process Paperless Refills
+45 ;I +$$GET1^DIQ(9009033,+$G(DIV),315,"I") D
+46 ;.;IHS/MSC/PLS - 08/25/10 - Logic changed to obtain cached POV from Parameter
+47 ;.;Q:'$L($G(^XTMP("APSPPCC.VPOV",+IEN,+REF)))
+48 ;.Q:'$D(^PSRX(IEN,1,REF)) ; Refill check
+49 ;.;S POV=$G(^XTMP("APSPPCC.VPOV",IEN,REF))
+50 ;.S POV=$TR($$GET^XPAR("SYS","APSP POV CACHE",+IEN_","_+REF),"~",U)
+51 ;.Q:'$L(POV)
+52 ;.S DAT=$P(DAT,".")_".13"
+53 ;.;K ^XTMP("APSPPCC.VPOV",IEN,REF)
+54 ; Check for cached POV
+55 ;IHS/MSC/PLS - 07/16/13 - POV no longer captured
+56 ;IHS/MSC/PLS - 06/04/14 - POV is being used again as a hardcoded set in APSPPCC1
+57 SET POV=$TRANSLATE($$GET^XPAR("SYS","APSP POV CACHE",+IEN_","_+REF),"~",U)
+58 ;S POV=""
+59 ; Refills or suspended prescriptions will be set to 1300 unless the
+60 ; suspended prescription is an original dispensed on the day of release.
+61 ;I $L(POV),$$GET1^DIQ(9009033,PSOSITE,405,"I") D ;IHS/MSC/PLS - 10/28/11 - Capture POV for all prescriptions
+62 ;IHS/MSC/PLS - 01/07/13 - Wrap with $G
IF $LENGTH(POV)
IF $$GET1^DIQ(9009033,$GET(PSOSITE),405,"I")
Begin DoDot:1
+63 ;S DAT=$P(DAT,".")_".13"
SET DAT=DAT
End DoDot:1
+64 ;E I $L(POV),$P(RX0,U,13)'=$P(DAT,".") D ; if issue date<>fill date
+65 ;.S DAT=$P(DAT,".")_".13"
+66 IF '$TEST
Begin DoDot:1
+67 IF $LENGTH(POV)&(ACT'="-")
DO DEL^XPAR("SYS","APSP POV CACHE",+IEN_","_+REF)
+68 KILL POV
End DoDot:1
+69 ; Provider is set to Clerk if Paperless Refill otherwise to Ordering Provider
+70 ;S (OPV,PRV)=$S($D(POV):$$NPF($P(RF0,U,7)),1:$$NPF(+$P(RX0,U,4)))
+71 ;IHS/CIA/PLS - 10/07/05 - Changed following line to look at clerk if paperless refill, refill provider if regular refill or prescription provider
+72 ;S PRV=$S($D(POV):$$NPF($P(RF0,U,7)),1:$$NPF(+$P(RX0,U,4)))
+73 ;IHS/MSC/PLS - 10/23/07 - Changed following line to add support for requesting refill provider
+74 ;S PRV=$S($D(POV):$$NPF($P(RF0,U,7)),REF:$$NPF($P(RF0,U,17)),1:$$NPF(+$P(RX0,U,4)))
+75 ;p1010
SET PRV=$SELECT($DATA(POV):$SELECT(REF:$$NPF($PIECE(RF0,U,7)),1:$$NPF(+$PIECE($GET(^PSRX(IEN,"OR1")),U,5))),REF:$$REFPRV(IEN,REF),1:$$NPF(+$PIECE(RX0,U,4)))
+76 ;Provider
SET OPV=$SELECT(REF:$$NPF($PIECE(RF0,U,17)),1:$$NPF(+$PIECE(RX0,U,4)))
+77 ;Pharmacist
SET PHM=$$NPF(+$PIECE(RX2,U,3))
+78 ;Clerk Code
IF REF
SET PHM=$$NPF($PIECE(RF0,U,7))
+79 ;Finishing Person
IF 'PHM
SET PHM=$$NPF(+$PIECE($GET(^PSRX(IEN,"OR1")),U,5))
+80 ;Entered By
IF 'PHM
SET PHM=$$NPF(+$PIECE(RX0,U,16))
+81 SET QTY=$PIECE(RF0,U,$SELECT(REF:4,1:7))
+82 SET DAY=$PIECE(RF0,U,$SELECT(REF:10,1:8))
+83 ;S VMED=+$S(REF:$G(^PSRX(IEN,1,REF,999999911)),1:$G(^PSRX(IEN,999999911)))
+84 ;;S ACT=$S(STA=13:"-",STA=16:"-",STA=3:"-",VMED:"",1:"+")
+85 ;;IHS/MSC/PLS - 01/28/09 - Added check for suspense status
+86 ;S ACT=$S(STA=13:"-",STA=16:"-",STA=3:"-",STA=5:"-",VMED:"",1:"+")
+87 ;I 'VMED,ACT="-" Q
+88 SET VM0=$SELECT(VMED:$GET(^AUPNVMED(VMED,0)),1:"")
+89 SET VSIT=$PIECE(VM0,U,3)
+90 SET VSVCCAT="A"
+91 ;IHS/CIA/PLS - 10/07/05 - Changed to pass clinic (if defined) or zero for ancillary
+92 ;S LOC=$S($D(POV):$O(^DIC(40.7,"C",39,0)),1:0) ; Set location to pharmacy stop code if Paperless refill
+93 ;Old format = VSTR format = zero or Clinic Stop Code; Date/Time of Visit;Visit Category
+94 ; IHS/CIA/PLS - 12/30/05 - Call to adjust the hospital location for REFILL and RENEWED orders
SET LOC=$$LOCADJ(LOC,IEN,RXID)
+95 IF $DATA(POV)
SET LOC=0
+96 ; New VSTR format = Hospital Location IEN; Date/Time of Visit;Visit Category
+97 ; Electronic Pharmacy
IF $PIECE($GET(^PSRX(IEN,999999921)),U,4)
Begin DoDot:1
+98 NEW EPHARM
+99 SET EPHARM=$$GET1^DIQ(9009033.9,$$GET1^DIQ(52,IEN,9999999.24,"I"),.01)
+100 SET VSIT=$SELECT('VSIT:";"_DEFOLOC_";"_EPHARM,1:VSIT)
+101 SET VSVCCAT="E"
End DoDot:1
+102 ; Location is either a pointer to clinic stop code or a zero
SET VSTR=LOC_";"_DAT_";"_VSVCCAT_";"_VSIT
+103 ;S (PRV,PHM,PRI)=0
+104 IF $DATA(POV)
Begin DoDot:1
+105 SET PRI=1
SET PHM=0
+106 ;Find or create a visit using clerk code
SET X=$$VSTR2VIS^APSPPCCV(DFN,.VSTR,1,PRV,DIV,1)
End DoDot:1
+107 IF '$TEST
Begin DoDot:1
+108 ;Find or create a visit using ordering provider
SET X=$$VSTR2VIS^APSPPCCV(DFN,.VSTR,1,PRV,DIV,0)
+109 ;I X'>0!(+VSTR=PLOC) S LOC=PLOC,$P(VSTR,";")=PLOC,PRV=0,PHM=0,PRI=1
+110 IF X'>0
SET PRV=0
SET PHM=0
SET PRI=1
+111 IF '$TEST
SET (PRV,PHM,PRI)=0
End DoDot:1
+112 DO ADD("HDR^^^"_VSTR)
+113 DO ADD("VST^PT^"_DFN)
+114 DO ADD("VST^DT^"_DAT)
+115 IF $DATA(POV)&PRV
DO ADD("PRV^"_PRV_"^^^^"_PRI)
+116 IF PHM
DO ADD("PRV^"_PHM_"^^^^0")
POV IF $DATA(POV)
Begin DoDot:1
+1 ;D:POV'="" ADD("POV^"_$P(POV,U)_"^^"_$P(POV,U,2)_"^0^2") ;IHS/MSC/PLS - 02/04/2008 - Changed to secondary
+2 ;D:POV'="" ADD("POV^"_$P(POV,U)_"^^"_$P(POV,U,2)_U_$S(REF:0,1:1)_U_$S(REF:2,1:1)) ;IHS/MSC/PLS - 04/21/2011
+3 ;D:REF ADD("POV^"_"V68.1"_"^^"_$$PRVNARR("MEDICATION REFILL")_"^1^2") ;IHS/MSC/PLS - 02/04/2008 - Changed to primary
+4 ;IHS/MSC/PLS - 09/22/2014
IF POV'=""
DO ADD("POV^"_$PIECE(POV,U)_"^^^1^"_$SELECT(REF:2,1:1))
+5 ;IHS/MSC/PLS - 08/25/2010 - remove the cached data
+6 ;Leave in cache
IF ACT="-"
QUIT
+7 DO DEL^XPAR("SYS","APSP POV CACHE",+IEN_","_+REF)
End DoDot:1
+8 IF VM0
IF DRG'=+VM0
DO ADD("RX-^"_+VM0_U_VMED_U_IEN_U_REF)
SET ACT="+"
+9 DO ADD("RX"_ACT_U_DRG_U_VMED_U_IEN_U_REF_U_$SELECT(OPV:OPV,1:"")_U_QTY_U_DAY_U_$SELECT(RTS:RTS,1:CAN)_U_RXID)
+10 IF $LENGTH(COM)
DO ADD("COM^1^"_COM)
+11 DO ADD("SIG^1^"_$SELECT($LENGTH(SIG)<146:SIG,1:$EXTRACT(SIG,1,144)_"~"))
+12 DO LOG("PCC",.MSG)
+13 DO SAVE^APSPPCCV(.ERR,.PCC)
+14 QUIT
+15 ; Add to PCC array
ADD(X) SET PCC=$GET(PCC)+1
SET PCC(PCC)=X
+1 QUIT
+2 ; Adjust file 200 pointer if file 16 conversion not done
NPF(IEN) QUIT +$SELECT('$DATA(^VA(200,+IEN,0)):0,$PIECE($GET(^AUTTSITE(1,0)),U,22):IEN,1:$PIECE(^VA(200,+IEN,0),U,16))
+1 ; Return institution if PCC capture enabled for division
INS(DIV) QUIT $SELECT($PIECE($GET(^APSPCTRL(+DIV,0)),U,15)="Y":+$GET(^PS(59,+DIV,"INI")),1:0)
+1 ; Return specified segment, starting at line LP
SEG(TYP,LP) ;
+1 FOR
SET LP=$ORDER(MSG(LP))
IF 'LP
QUIT
IF $EXTRACT(MSG(LP),1,$LENGTH(TYP))=TYP
QUIT
+2 QUIT $SELECT(LP:MSG(LP),1:"")
+3 ; Send a bulletin on error
BUL(IEN,DFN,MSG,ERR) ;
+1 NEW XMB,XMTEXT,XMY,XMDUZ,XMDT,XMYBLOB,XMZ
+2 SET XMB="APSP LINK FAIL VMED"
+3 SET XMB(1)=$GET(IEN,"UNKNOWN")
+4 SET XMB(2)=$PIECE($GET(^DPT(DFN,0)),U)
+5 SET XMB(3)=$GET(MSG,"UNKNOWN")
+6 SET XMB(4)=$$FMTE^XLFDT(DT)
+7 SET XMB(5)=$PIECE(ERR,U,2)
+8 SET XMDUZ=.5
+9 DO ^XMB
+10 QUIT
+11 ; Log data
LOG(ARY,CNT) ;
+1 IF '$GET(CNT)
QUIT
+2 IF '$$GET^XPAR("ALL","APSPPCC LOG MESSAGES")
QUIT
+3 NEW SUB,NMSP
+4 SET SUB="APSPPCC"
SET NMSP=$TRANSLATE($PIECE(ARY,"("),U)
+5 LOCK +^XTMP(SUB):2
+6 SET ^XTMP(SUB,0)=$$FMADD^XLFDT(DT,7)_U_$$DT^XLFDT
+7 IF CNT<0
SET CNT=1+$ORDER(^XTMP(SUB,""),-1)
+8 KILL ^XTMP(SUB,CNT,NMSP)
+9 MERGE ^XTMP(SUB,CNT,NMSP)=@ARY
+10 LOCK -^XTMP(SUB)
+11 QUIT
+12 ; Return Provider Narrative IEN
PRVNARR(TXT) ; EP
+1 NEW IEN,FDA,IENS,ERR
+2 IF '$LENGTH(TXT)
QUIT ""
+3 ; IHS/MSC/PLS - 02/05/08 - Changed lookup to 30 characters
SET IEN=$ORDER(^AUTNPOV("B",$EXTRACT(TXT,1,30),0))
+4 IF 'IEN
Begin DoDot:1
+5 ; IHS/MSC/PLS - 02/05/08 - Changed set to 80 characters
SET FDA(9999999.27,"+1,",.01)=$EXTRACT(TXT,1,80)
+6 DO UPDATE^DIE("","FDA","IENS","ERR")
+7 IF $GET(ERR)
SET IEN=""
+8 IF '$TEST
SET IEN=$GET(IENS(1))
End DoDot:1
+9 QUIT IEN
+10 ; Return Inpatient Location IEN or Zero
+11 ; VAINDT contains inpatient admission date or defaults to today
INPAT(DFN,VAINDT) ;
+1 NEW RET,VAIN
+2 DO INP^VADPT
+3 SET RET=+$GET(VAIN(4))
+4 QUIT RET
+5 ; Return adjusted Hospital Location IEN
+6 ; The visit location will be returned as zero using the following rules:
+7 ; 1) Refill orders - Orders processed using options other than PSO LMOE FINISH
+8 ; 2) Renew orders - Orders processed using options other than PSO LMOE FINISH
+9 ;
LOCADJ(LOC,RXIEN,RXN) ;EP
+1 IF $GET(PSOFROM)="REFILL"
IF $GET(XQY0)'["PSO LMOE FINISH"
SET LOC=0
+2 IF $GET(PSOFROM)="NEW"
IF RXN?.N1.U
IF $GET(XQY0)'["PSO LMOE FINISH"
SET LOC=0
+3 ; IHS/MSC/PLS - 01/27/2009 - If new prescription and Fill Date <> Issue Date
+4 IF $GET(PSOFROM)="NEW"
IF ($PIECE($GET(^PSRX(RXIEN,2)),U,2)'=$PIECE($GET(^PSRX(RXIEN,0)),U,13))
SET LOC=0
+5 QUIT LOC
+6 ; IHS/MSC/PLS - 10/24/07
REFPRV(RX,REF) ;EP
+1 NEW RES,PRV,RPRV
+2 SET PRV=$PIECE(^PSRX(RX,1,REF,0),U,17)
+3 ;IHS/MSC/PLS - 01/28/14 added $G
SET RPRV=$PIECE($GET(^PSRX(RX,1,REF,9999999)),U)
+4 SET RES=$SELECT(RPRV:RPRV,1:PRV)
+5 QUIT RES
