Routine: APSPPCC

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

 ; 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

 ; 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

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)

 ; Add to PCC array

ADD(X) S PCC=$G(PCC)+1,PCC(PCC)=X

 ; 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

 ; 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)

 ; 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

APSPPCC.m