APSPPCCV ;IHS/CIA/DKM/PLS - PCC Data Management ;26-Oct-2015 17:40;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1004,1005,1006,1007,1009,1018,1020**;Sep 23, 2004;Build 7
; Modified - IHS/CIA/PLS - 10/07/05
; IHS/MSC/PLS - 04/03/06
; - 10/31/06
; - 01/03/07 - Added logic to find an ancillary rx visit when more than one visit is returned
; - 09/26/07 - Added $GET to FNDVIS+5
; - 11/08/07 - Added RXV line label
; - 03/28/08 - Added logic to set Prescription Number into field 1102 of V MED file
; - 06/21/10 - Added line RXV+9
; - 06/03/14 - Modified the POV subroutine
; - 10/26/15 - Added N DIERR at STORE+16
; RPC: Update PCC data
; DATA = Returned as 0 if successful
; PCC = Array of PCC data to process
; X,Y = Not used (but required)
SAVE(DATA,PCC,X,Y) ;EP
N IDX,TYP,CODE,VST,VSTR,ADD,DEL,VAL,DFN,PRV,FLD,DAT,COM,EVT
S IDX=0,DATA=0,PRV=0
F S IDX=$O(PCC(IDX)) Q:'IDX!DATA D
.S VAL=PCC(IDX),TYP=$P(VAL,U),CODE=$P(VAL,U,2),ADD=TYP["+",DEL=TYP["-",TYP=$TR(TYP,"+-")
.D LOOK("COM",.COM)
.I TYP?1.3AN,$T(@TYP)'="" D @TYP
S EVT=""
F S EVT=$O(EVT(EVT)) Q:'$L(EVT) D
.D BRDCAST^CIANBEVT("PCC."_EVT(EVT)_"."_EVT)
Q
; Look ahead for modifiers
; TYP = modifier type
; ARY = array to receive data
LOOK(TYP,ARY) ;EP
K ARY
N IDX2,CNT
S IDX2=IDX
F CNT=0:1 S IDX2=$O(PCC(IDX2)) Q:'IDX2 Q:$P(PCC(IDX2),U)'=TYP D
.I CNT S ARY(CNT)=PCC(IDX2)
.E S ARY=PCC(IDX2)
.S IDX=IDX2
Q
SET(FLN,PC,CV) ;EP
S PC=$P(VAL,U,PC),FLD(FLN)=$S($D(CV):$$SET^CIAU(PC,CV),$L(PC):PC,1:"@")
Q
; Find an existing V file entry
; CRT = Scalar or array of additional criteria in (field|format|value) format
FIND(FN,CODE,VST,CRT) ;EP
N GBL,IEN
S GBL=$$ROOT^DILFD(FN,,1),IEN=0
S:$L($G(CRT)) CRT(-1)=CRT
F S IEN=+$O(@GBL@("AD",VST,IEN)) Q:'IEN Q:$P($G(@GBL@(IEN,0)),U)=CODE&$$EVAL(.CRT)
Q IEN
; Evaluate list of additional fields and values
EVAL(ARY) ;EP
N LP,RES,ITM,TYP,FLD
S RES=1,LP=""
F S LP=$O(CRT(LP)) Q:LP="" D Q:'RES
.S ITM=CRT(LP),FLD=$P(ITM,"|"),TYP=$P(ITM,"|",2),TYP=$S($L(TYP):TYP,1:"E"),ITM=$P(ITM,"|",3,99)
.I FLD=.001 S RES=IEN=ITM
.E S RES=$$GET1^DIQ(FN,IEN,FLD,TYP)=ITM
Q RES
; Store the data in the specified V file
; FN = Fractional portion of V file file #
; CF = Field # of comment field (0=none; defaults to 81101)
; CRT = Additional lookup criteria
STORE(FN,CF,CRT) ;EP
N CIAFLD,CIAERR,CIAIEN,IEN
S:'$G(VST) VST=$$VSTR2VIS(DFN,.VSTR,'DEL)
I VST'>0 S:'DEL DATA="-1^Cannot create visit." G STXIT
S FN=9000010+FN
S:'$D(CF) CF=81101
I ADD S IEN="+1"
E S IEN=$$FIND(FN,CODE,VST,.CRT) I 'IEN G:DEL STXIT S IEN="+1"
S:'$D(FLD(.01)) FLD(.01)=$S(DEL:"@",1:CODE)
S FLD(.02)=DFN
S FLD(.03)=VST
S:CF&$D(COM) FLD(CF)=$P(COM,U,3,999)
S:'$D(FLD(1204))&(PRV>0) FLD(1204)=PRV
S:'$D(FLD(1201))&$G(DAT) FLD(1201)=DAT
M CIAFLD(FN,IEN_",")=FLD
K FLD
N DIERR ;P1020
D UPDATE^DIE("","CIAFLD","CIAIEN","CIAERR")
S:$G(DIERR) DATA=-CIAERR("DIERR",1)_U_CIAERR("DIERR",1,"TEXT",1)
S:$G(CIAIEN(1)) IEN=$G(CIAIEN(1))
;IHS/CIA/PLS - 10/07/05 - Remove a pharmacy created visit if no dependents
I VST,DEL D
.Q:$$GET1^DIQ(9000010,VST,.09) ;Quit if dependent count not zero
.Q:$$GET1^DIQ(9000010,VST,.25,"I")'=$$GETPROT() ;Quit if protocol is not pharmacy protocol
.Q:$$GET1^DIQ(9000010,VST,.24,"I")'=$$GETOPT() ; Quit if option is not pharmacy option
.D DELVSIT(VST)
S EVT(TYP)=DFN
;IHS exemption approved on 3/29/2007
STXIT Q:$Q $G(IEN)
Q
HDR ;; Visit string
S VSTR=$P(VAL,U,4)
Q
VST ;; Patient and encounter date
S:CODE="PT" DFN=+$P(VAL,U,3)
S:CODE="DT" DAT=+$P(VAL,U,3)
Q
PRV ;; Provider
S PRV=+CODE,ADD=0
D:PRV>0 SET(.04,6,"1:P;0:S;:@"),STORE(.06)
Q
POV ;; Purpose of visit
N NAR,VAL1,SNO,DESC,X,TXT,PICD
;IHS/MSC/MGH updated to use correct lookup
;S CODE=$$FIND1^DIC(80,,"X",CODE_" ","BA")
;MGH Patch 1018 fix for adding SNOMED codes to POV
S SNO=373784005
S X=$$CONC^BSTSAPI(SNO_"^^^1")
S DESC=$P(X,U,3)
S PICD=$P(X,U,5)
S $P(VAL,U,7)=SNO
S $P(VAL,U,8)=DESC
I $$AICD S CODE=$P($$CODEN^ICDEX(CODE,80),"~",1)
E S CODE=+$$CODEN^ICDCODE(CODE,80)
Q:CODE'>0
S TXT=$P(VAL,U,4)
S $P(VAL,U,4)=$$NARR(TXT_"|"_DESC)
D:CODE>0 SET(.04,4),SET(.12,5,"1:P;0:S;:@"),SET(.08,6),SET(1101,7),SET(1102,8),STORE(.07)
Q
; Lookup and optionally add narrative
; Returns pointer to PROVIDER NARRATIVE file
NARR(DESCT) ;
N IEN,TRC,NARR,FDA,TXT
Q:'$L(DESCT) ""
S TXT=$E(DESCT,1,160),TRC=$E(DESCT,1,30)
F IEN=0:0 S IEN=$O(^AUTNPOV("B",TRC,IEN)) Q:'IEN Q:$P($G(^AUTNPOV(IEN,0)),U)=TXT
Q:IEN IEN
S FDA(9999999.27,"+1,",.01)=TXT
D UPDATE^DIE("E","FDA","IEN","ERR")
Q $G(IEN(1))
CPT ;; CPT codes
S CODE=+$$CPT^ICPTCOD(CODE)
D:CODE>0 SET(.16,5),STORE(.18)
Q
;
RX ; Prescriptions
N SIG,IEN,VMED,CRT
D LOOK("SIG",.SIG)
S FLD(.05)=$P($G(SIG),U,3)
D SET(1202,6),SET(.06,7),SET(.07,8),SET(.08,9),SET(1102,10)
S VMED=$P(VAL,U,3)
S:VMED CRT=".001|I|"_VMED
S IEN=$$STORE(.14,1101,.CRT)
I IEN!DEL D
.N RXN,RFN,FN,IENS,CIAFLD,CIAIEN,CIAERR
.S RXN=$P(VAL,U,4),RFN=$P(VAL,U,5)
.S IENS=$S(RFN:RFN_","_RXN_",",1:RXN_",")
.S FN=$S(RFN:52.1,1:52)
.S CIAFLD(FN,IENS,9999999.11)=$S(DEL:"@",1:IEN)
.D UPDATE^DIE("","CIAFLD","CIAIEN","CIAERR")
.S:$G(DIERR) DATA=-CIAERR("DIERR",1)_U_CIAERR("DIERR",1,"TEXT",1)
Q
RXV ; Non-VA Meds
N SIG,IEN,VMED,CRT
D LOOK("SIG",.SIG)
D SET(1108,4)
S FLD(.05)=$P($G(SIG),U,3)
D SET(1202,6),SET(.06,7),SET(.07,8),SET(.08,9)
S VMED=$P(VAL,U,3)
S:VMED CRT=".001|I|"_VMED
S IEN=$$STORE(.14,1101,.CRT)
S:IEN="+1" IEN="" ;IHS/MSC/PLS - 06/21/10
I IEN!DEL D
.N NVA,RFN,FN,IENS,CIAFLD,CIAIEN,CIAERR,DFN
.S IENS=+$P(VAL,U,4)_","_$P(VAL,U,5)_","
.S FN=55.05
.S CIAFLD(FN,IENS,9999999.11)=$S(DEL:"@",1:IEN)
.D UPDATE^DIE("","CIAFLD","CIAIEN","CIAERR")
.S:$G(DIERR) DATA=-CIAERR("DIERR",1)_U_CIAERR("DIERR",1,"TEXT",1)
Q
; RPC: Fetch visit IEN given visit id
VID2IEN(DATA,VID) ;EP
S DATA=$$VID2IEN^VSIT(VID)
Q
; Find a visit (internal use only)
; DFN = Patient IEN
; DAT = Visit date/time
; CAT = Service category
; LOC = Hospital Location IEN(44) Defaults to zero (A nonzero value indicates that the Clinic was defined during prescription processing)
; CRE = Force create?
; PRV = Provider IEN to restrict search (optional)
; PDIV = Pharmacy division (File 59 IEN)
; PRF = Paperless refill flag
; TYP = Visit Type
; OLOC = Other location
; OSID = Outside Location
FNDVIS(DFN,DAT,CAT,LOC,CRE,PRV,PDIV,PRF,TYP,OLOC,OSID) ;
N IN,OUT,IEN,DIF,FVST
S IN("PAT")=DFN
S IN("VISIT DATE")=DAT
S IN("SITE")=$S($G(OLOC):$$ABS(OLOC),1:DUZ(2))
I $G(TYP)="O" D
.S IN("APCDOLOC")=$S($L($G(OSID)):OSID,1:"OUTSIDE MED")
.S IN("APCDLOC")=$$ABS(OLOC)
S IN("VISIT TYPE")=$S($L($G(TYP)):TYP,$P($G(^APCCCTRL(DUZ(2),0)),U,4)]"":$P(^(0),U,4),1:"I")
S IN("SRV CAT")=CAT
S IN("USR")=DUZ
S IN("APCDOPT")=$$GETOPT()
S IN("APCDPROT")=$$GETPROT()
I LOC D
.S IN("HOS LOC")=LOC
.I LOC=$$GET1^DIQ(9009033,$G(PDIV),317,"I") D
..S IN("TIME RANGE")=0
..S:$G(PRV)&PRF IN("PROVIDER")=PRV
.E D
..S IN("TIME RANGE")=-1
..S:$G(PRV) IN("PROVIDER")=PRV
..S IN("ANCILLARY")=1 ; IHS/MSC/PLS - 04/03/06
E D
.S IN("TIME RANGE")=0
.S IN("HOS LOC")=$$GET1^DIQ(9009033,$G(PDIV),317,"I")
.S:$G(PRV)&PRF IN("PROVIDER")=PRV
K:CAT="E" IN("HOS LOC")
I CRE<0 D Q IEN
.S IN("FORCE ADD")=1
.S IEN=$$MAKEVST(.IN) ; Force Create and return visit
E D
.K:'CRE IN("ANCILLARY")
.S IN("NEVER ADD")=1
.S FVST=$$FNDVSTX(.IN)
Q $S(FVST:FVST,CRE>0:$$MAKEVST(.IN),1:0)
; Return whether an existing visit can be used or need to create one.
FNDVSTX(CRIT) ;
N IEN,RET,EFLG
S RET=0
D GETVISIT^BSDAPI4(.CRIT,.OUT)
Q:'OUT(0) RET ; No visits were found
S IEN=0,EFLG=0
F S IEN=$O(OUT(IEN)) Q:'IEN D Q:EFLG
.D:OUT(IEN)="ADD" BRDCAST^CIANBEVT("PCC."_DFN_".VST",IEN)
.I PRF,$$CKRXVST(IEN,13) S EFLG=1,RET=IEN Q
.I 'PRF,$$CKRXVST(IEN,13) D
..K OUT(IEN)
..S OUT(0)=OUT(0)-1
Q $S(RET:RET,OUT(0)=1:$O(OUT(0)),1:$$ANCVCK(.OUT))
;
MAKEVST(CRIT) ;
N RET,OUT
K CRIT("NEVER ADD")
S CRIT("FORCE ADD")=1
S CRIT("HOS LOC")=$S(IN("SRV CAT")="E":"",LOC:+LOC,1:$$GET1^DIQ(9009033,$G(PDIV),317,"I")) ;SET TO PHARMACY HOSPITAL LOCATION
S CRIT("CLINIC CODE")=$$GET1^DIQ(44,CRIT("HOS LOC"),8,"I")
D GETVISIT^BSDAPI4(.CRIT,.OUT)
Q:'OUT(0) OUT(0)
S RET=+$O(OUT(0))
D:OUT(RET)="ADD" BRDCAST^CIANBEVT("PCC."_DFN_".VST",RET)
Q RET
; Check visit for a Pharmacy visit (ancillary or paperless refill) and matching time
; Time is passed, Protocol and Option to Create are pharmacy options
CKRXVST(VIEN,TM) ; EP
N PRT,OPT
S TM=$P($$GET1^DIQ(9000010,VIEN,.01,"I"),".",2)=TM
S PRT=$$GET1^DIQ(9000010,VIEN,.25,"I")=$$GETPROT()
S OPT=$$GET1^DIQ(9000010,VIEN,.24,"I")=$$GETOPT()
Q TM&PRT&OPT
; Check visits in array for existence of RX ancillary visit and return first ancillary visit
ANCVCK(VARY) ; EP
;Q 0
N VIEN,RES
S RES=0
S VIEN=0
F S VIEN=$O(VARY(VIEN)) Q:'VIEN D Q:RES
.S:$$CKRXVST(VIEN,12) RES=VIEN
Q RES
; Return absolute value
ABS(X) Q $S(X<0:-X,1:X)
; Return a visit ien from a visit string (create if necessary)
; DFN = Patient IEN
; VSTR = Visit string (format: Hospital Location IEN or zero;Date of Service;Service Category;Visit IEN;outside med other location (- number = outside med, + number = other pharmacy)
; CREATE = Create flag
; 0 = Don't create
; >0 = Create if not found
; <0 = Always create
; PRV = Provider IEN to restrict visit search (optional)
; PDIV = Pharmacy Division (optional) Used for lookup of associated Hospital Location
; PRF = Paperless Refill Flag
VSTR2VIS(DFN,VSTR,CREATE,PRV,PDIV,PRF) ;EP
N IEN,DAT,CAT,LOC,FLG,VSIT,LP,APCDALVR,TYP,OLOC,OSID
S LOC=+VSTR,DAT=+$P(VSTR,";",2),CAT=$P(VSTR,";",3),IEN=+$P(VSTR,";",4),CREATE=+$G(CREATE)
S OLOC=$P(VSTR,";",5),TYP=$S(OLOC:"O",1:""),OSID=$P(VSTR,";",6)
S:'IEN IEN=$$FNDVIS(DFN,DAT,CAT,LOC,CREATE,.PRV,+$G(PDIV),+$G(PRF),TYP,OLOC,OSID)
I IEN>0 D
.S VSTR=$G(^AUPNVSIT(+IEN,0))
.I '$L(VSTR) S IEN="-1^Visit does not exist"
.E I $P(VSTR,U,5)'=DFN S IEN="-1^Visit does not belong to current patient"
.E S VSTR=$S($P(VSTR,U,22):$P(VSTR,U,22),1:LOC)_";"_+VSTR_";"_$P(VSTR,U,7)_";"_+IEN ; IHS/MSC/PLS - 10/31/06 - Correct issue with Hosp Loc piece
Q IEN
; Build PCC array
ADDPCC(X) ;
S:'$D(PCC) PCC(1)="HDR^^^"_VSTR,PCC(2)="VST^PT^"_DFN
S PCC($O(PCC(""),-1)+1)=X
Q
; Return Option IEN used to Create
GETOPT() ;EP
N RET
S RET=$$FIND1^DIC(19,,"O","PSO LM BACKDOOR ORDERS")
Q $S(RET:RET,1:"")
; Return Protocol IEN used to Create
GETPROT() ;EP
N RET
S RET=$$FIND1^DIC(101,,"O","IHS PS HOOK")
Q $S(RET:RET,1:"")
;
DELVSIT(VST) ;EP
N APCDVLDT,U,APCDVFLE,AUPNVSIT,APCDVNM,APCDVDG,APCDVIGR,APCDVDFN
N APCDVI,DIK,DA
S APCDVDLT=VST
D EN^APCDVDLT
Q
AICD() ;EP
Q $S($$VERSION^XPDUTL("AICD")<"4.0":0,1:1)
APSPPCCV ;IHS/CIA/DKM/PLS - PCC Data Management ;26-Oct-2015 17:40;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1003,1004,1005,1006,1007,1009,1018,1020**;Sep 23, 2004;Build 7
+2 ; Modified - IHS/CIA/PLS - 10/07/05
+3 ; IHS/MSC/PLS - 04/03/06
+4 ; - 10/31/06
+5 ; - 01/03/07 - Added logic to find an ancillary rx visit when more than one visit is returned
+6 ; - 09/26/07 - Added $GET to FNDVIS+5
+7 ; - 11/08/07 - Added RXV line label
+8 ; - 03/28/08 - Added logic to set Prescription Number into field 1102 of V MED file
+9 ; - 06/21/10 - Added line RXV+9
+10 ; - 06/03/14 - Modified the POV subroutine
+11 ; - 10/26/15 - Added N DIERR at STORE+16
+12 ; RPC: Update PCC data
+13 ; DATA = Returned as 0 if successful
+14 ; PCC = Array of PCC data to process
+15 ; X,Y = Not used (but required)
SAVE(DATA,PCC,X,Y) ;EP
+1 NEW IDX,TYP,CODE,VST,VSTR,ADD,DEL,VAL,DFN,PRV,FLD,DAT,COM,EVT
+2 SET IDX=0
SET DATA=0
SET PRV=0
+3 FOR
SET IDX=$ORDER(PCC(IDX))
IF 'IDX!DATA
QUIT
Begin DoDot:1
+4 SET VAL=PCC(IDX)
SET TYP=$PIECE(VAL,U)
SET CODE=$PIECE(VAL,U,2)
SET ADD=TYP["+"
SET DEL=TYP["-"
SET TYP=$TRANSLATE(TYP,"+-")
+5 DO LOOK("COM",.COM)
+6 IF TYP?1.3AN
IF $TEXT(@TYP)'=""
DO @TYP
End DoDot:1
+7 SET EVT=""
+8 FOR
SET EVT=$ORDER(EVT(EVT))
IF '$LENGTH(EVT)
QUIT
Begin DoDot:1
+9 DO BRDCAST^CIANBEVT("PCC."_EVT(EVT)_"."_EVT)
End DoDot:1
+10 QUIT
+11 ; Look ahead for modifiers
+12 ; TYP = modifier type
+13 ; ARY = array to receive data
LOOK(TYP,ARY) ;EP
+1 KILL ARY
+2 NEW IDX2,CNT
+3 SET IDX2=IDX
+4 FOR CNT=0:1
SET IDX2=$ORDER(PCC(IDX2))
IF 'IDX2
QUIT
IF $PIECE(PCC(IDX2),U)'=TYP
QUIT
Begin DoDot:1
+5 IF CNT
SET ARY(CNT)=PCC(IDX2)
+6 IF '$TEST
SET ARY=PCC(IDX2)
+7 SET IDX=IDX2
End DoDot:1
+8 QUIT
SET(FLN,PC,CV) ;EP
+1 SET PC=$PIECE(VAL,U,PC)
SET FLD(FLN)=$SELECT($DATA(CV):$$SET^CIAU(PC,CV),$LENGTH(PC):PC,1:"@")
+2 QUIT
+3 ; Find an existing V file entry
+4 ; CRT = Scalar or array of additional criteria in (field|format|value) format
FIND(FN,CODE,VST,CRT) ;EP
+1 NEW GBL,IEN
+2 SET GBL=$$ROOT^DILFD(FN,,1)
SET IEN=0
+3 IF $LENGTH($GET(CRT))
SET CRT(-1)=CRT
+4 FOR
SET IEN=+$ORDER(@GBL@("AD",VST,IEN))
IF 'IEN
QUIT
IF $PIECE($GET(@GBL@(IEN,0)),U)=CODE&$$EVAL(.CRT)
QUIT
+5 QUIT IEN
+6 ; Evaluate list of additional fields and values
EVAL(ARY) ;EP
+1 NEW LP,RES,ITM,TYP,FLD
+2 SET RES=1
SET LP=""
+3 FOR
SET LP=$ORDER(CRT(LP))
IF LP=""
QUIT
Begin DoDot:1
+4 SET ITM=CRT(LP)
SET FLD=$PIECE(ITM,"|")
SET TYP=$PIECE(ITM,"|",2)
SET TYP=$SELECT($LENGTH(TYP):TYP,1:"E")
SET ITM=$PIECE(ITM,"|",3,99)
+5 IF FLD=.001
SET RES=IEN=ITM
+6 IF '$TEST
SET RES=$$GET1^DIQ(FN,IEN,FLD,TYP)=ITM
End DoDot:1
IF 'RES
QUIT
+7 QUIT RES
+8 ; Store the data in the specified V file
+9 ; FN = Fractional portion of V file file #
+10 ; CF = Field # of comment field (0=none; defaults to 81101)
+11 ; CRT = Additional lookup criteria
STORE(FN,CF,CRT) ;EP
+1 NEW CIAFLD,CIAERR,CIAIEN,IEN
+2 IF '$GET(VST)
SET VST=$$VSTR2VIS(DFN,.VSTR,'DEL)
+3 IF VST'>0
IF 'DEL
SET DATA="-1^Cannot create visit."
GOTO STXIT
+4 SET FN=9000010+FN
+5 IF '$DATA(CF)
SET CF=81101
+6 IF ADD
SET IEN="+1"
+7 IF '$TEST
SET IEN=$$FIND(FN,CODE,VST,.CRT)
IF 'IEN
IF DEL
GOTO STXIT
SET IEN="+1"
+8 IF '$DATA(FLD(.01))
SET FLD(.01)=$SELECT(DEL:"@",1:CODE)
+9 SET FLD(.02)=DFN
+10 SET FLD(.03)=VST
+11 IF CF&$DATA(COM)
SET FLD(CF)=$PIECE(COM,U,3,999)
+12 IF '$DATA(FLD(1204))&(PRV>0)
SET FLD(1204)=PRV
+13 IF '$DATA(FLD(1201))&$GET(DAT)
SET FLD(1201)=DAT
+14 MERGE CIAFLD(FN,IEN_",")=FLD
+15 KILL FLD
+16 ;P1020
NEW DIERR
+17 DO UPDATE^DIE("","CIAFLD","CIAIEN","CIAERR")
+18 IF $GET(DIERR)
SET DATA=-CIAERR("DIERR",1)_U_CIAERR("DIERR",1,"TEXT",1)
+19 IF $GET(CIAIEN(1))
SET IEN=$GET(CIAIEN(1))
+20 ;IHS/CIA/PLS - 10/07/05 - Remove a pharmacy created visit if no dependents
+21 IF VST
IF DEL
Begin DoDot:1
+22 ;Quit if dependent count not zero
IF $$GET1^DIQ(9000010,VST,.09)
QUIT
+23 ;Quit if protocol is not pharmacy protocol
IF $$GET1^DIQ(9000010,VST,.25,"I")'=$$GETPROT()
QUIT
+24 ; Quit if option is not pharmacy option
IF $$GET1^DIQ(9000010,VST,.24,"I")'=$$GETOPT()
QUIT
+25 DO DELVSIT(VST)
End DoDot:1
+26 SET EVT(TYP)=DFN
+27 ;IHS exemption approved on 3/29/2007
STXIT IF $QUIT
QUIT $GET(IEN)
+1 QUIT
HDR ;; Visit string
+1 SET VSTR=$PIECE(VAL,U,4)
+2 QUIT
VST ;; Patient and encounter date
+1 IF CODE="PT"
SET DFN=+$PIECE(VAL,U,3)
+2 IF CODE="DT"
SET DAT=+$PIECE(VAL,U,3)
+3 QUIT
PRV ;; Provider
+1 SET PRV=+CODE
SET ADD=0
+2 IF PRV>0
DO SET(.04,6,"1:P;0:S;:@")
DO STORE(.06)
+3 QUIT
POV ;; Purpose of visit
+1 NEW NAR,VAL1,SNO,DESC,X,TXT,PICD
+2 ;IHS/MSC/MGH updated to use correct lookup
+3 ;S CODE=$$FIND1^DIC(80,,"X",CODE_" ","BA")
+4 ;MGH Patch 1018 fix for adding SNOMED codes to POV
+5 SET SNO=373784005
+6 SET X=$$CONC^BSTSAPI(SNO_"^^^1")
+7 SET DESC=$PIECE(X,U,3)
+8 SET PICD=$PIECE(X,U,5)
+9 SET $PIECE(VAL,U,7)=SNO
+10 SET $PIECE(VAL,U,8)=DESC
+11 IF $$AICD
SET CODE=$PIECE($$CODEN^ICDEX(CODE,80),"~",1)
+12 IF '$TEST
SET CODE=+$$CODEN^ICDCODE(CODE,80)
+13 IF CODE'>0
QUIT
+14 SET TXT=$PIECE(VAL,U,4)
+15 SET $PIECE(VAL,U,4)=$$NARR(TXT_"|"_DESC)
+16 IF CODE>0
DO SET(.04,4)
DO SET(.12,5,"1:P;0:S;:@")
DO SET(.08,6)
DO SET(1101,7)
DO SET(1102,8)
DO STORE(.07)
+17 QUIT
+18 ; Lookup and optionally add narrative
+19 ; Returns pointer to PROVIDER NARRATIVE file
NARR(DESCT) ;
+1 NEW IEN,TRC,NARR,FDA,TXT
+2 IF '$LENGTH(DESCT)
QUIT ""
+3 SET TXT=$EXTRACT(DESCT,1,160)
SET TRC=$EXTRACT(DESCT,1,30)
+4 FOR IEN=0:0
SET IEN=$ORDER(^AUTNPOV("B",TRC,IEN))
IF 'IEN
QUIT
IF $PIECE($GET(^AUTNPOV(IEN,0)),U)=TXT
QUIT
+5 IF IEN
QUIT IEN
+6 SET FDA(9999999.27,"+1,",.01)=TXT
+7 DO UPDATE^DIE("E","FDA","IEN","ERR")
+8 QUIT $GET(IEN(1))
CPT ;; CPT codes
+1 SET CODE=+$$CPT^ICPTCOD(CODE)
+2 IF CODE>0
DO SET(.16,5)
DO STORE(.18)
+3 QUIT
+4 ;
RX ; Prescriptions
+1 NEW SIG,IEN,VMED,CRT
+2 DO LOOK("SIG",.SIG)
+3 SET FLD(.05)=$PIECE($GET(SIG),U,3)
+4 DO SET(1202,6)
DO SET(.06,7)
DO SET(.07,8)
DO SET(.08,9)
DO SET(1102,10)
+5 SET VMED=$PIECE(VAL,U,3)
+6 IF VMED
SET CRT=".001|I|"_VMED
+7 SET IEN=$$STORE(.14,1101,.CRT)
+8 IF IEN!DEL
Begin DoDot:1
+9 NEW RXN,RFN,FN,IENS,CIAFLD,CIAIEN,CIAERR
+10 SET RXN=$PIECE(VAL,U,4)
SET RFN=$PIECE(VAL,U,5)
+11 SET IENS=$SELECT(RFN:RFN_","_RXN_",",1:RXN_",")
+12 SET FN=$SELECT(RFN:52.1,1:52)
+13 SET CIAFLD(FN,IENS,9999999.11)=$SELECT(DEL:"@",1:IEN)
+14 DO UPDATE^DIE("","CIAFLD","CIAIEN","CIAERR")
+15 IF $GET(DIERR)
SET DATA=-CIAERR("DIERR",1)_U_CIAERR("DIERR",1,"TEXT",1)
End DoDot:1
+16 QUIT
RXV ; Non-VA Meds
+1 NEW SIG,IEN,VMED,CRT
+2 DO LOOK("SIG",.SIG)
+3 DO SET(1108,4)
+4 SET FLD(.05)=$PIECE($GET(SIG),U,3)
+5 DO SET(1202,6)
DO SET(.06,7)
DO SET(.07,8)
DO SET(.08,9)
+6 SET VMED=$PIECE(VAL,U,3)
+7 IF VMED
SET CRT=".001|I|"_VMED
+8 SET IEN=$$STORE(.14,1101,.CRT)
+9 ;IHS/MSC/PLS - 06/21/10
IF IEN="+1"
SET IEN=""
+10 IF IEN!DEL
Begin DoDot:1
+11 NEW NVA,RFN,FN,IENS,CIAFLD,CIAIEN,CIAERR,DFN
+12 SET IENS=+$PIECE(VAL,U,4)_","_$PIECE(VAL,U,5)_","
+13 SET FN=55.05
+14 SET CIAFLD(FN,IENS,9999999.11)=$SELECT(DEL:"@",1:IEN)
+15 DO UPDATE^DIE("","CIAFLD","CIAIEN","CIAERR")
+16 IF $GET(DIERR)
SET DATA=-CIAERR("DIERR",1)_U_CIAERR("DIERR",1,"TEXT",1)
End DoDot:1
+17 QUIT
+18 ; RPC: Fetch visit IEN given visit id
VID2IEN(DATA,VID) ;EP
+1 SET DATA=$$VID2IEN^VSIT(VID)
+2 QUIT
+3 ; Find a visit (internal use only)
+4 ; DFN = Patient IEN
+5 ; DAT = Visit date/time
+6 ; CAT = Service category
+7 ; LOC = Hospital Location IEN(44) Defaults to zero (A nonzero value indicates that the Clinic was defined during prescription processing)
+8 ; CRE = Force create?
+9 ; PRV = Provider IEN to restrict search (optional)
+10 ; PDIV = Pharmacy division (File 59 IEN)
+11 ; PRF = Paperless refill flag
+12 ; TYP = Visit Type
+13 ; OLOC = Other location
+14 ; OSID = Outside Location
FNDVIS(DFN,DAT,CAT,LOC,CRE,PRV,PDIV,PRF,TYP,OLOC,OSID) ;
+1 NEW IN,OUT,IEN,DIF,FVST
+2 SET IN("PAT")=DFN
+3 SET IN("VISIT DATE")=DAT
+4 SET IN("SITE")=$SELECT($GET(OLOC):$$ABS(OLOC),1:DUZ(2))
+5 IF $GET(TYP)="O"
Begin DoDot:1
+6 SET IN("APCDOLOC")=$SELECT($LENGTH($GET(OSID)):OSID,1:"OUTSIDE MED")
+7 SET IN("APCDLOC")=$$ABS(OLOC)
End DoDot:1
+8 SET IN("VISIT TYPE")=$SELECT($LENGTH($GET(TYP)):TYP,$PIECE($GET(^APCCCTRL(DUZ(2),0)),U,4)]"":$PIECE(^(0),U,4),1:"I")
+9 SET IN("SRV CAT")=CAT
+10 SET IN("USR")=DUZ
+11 SET IN("APCDOPT")=$$GETOPT()
+12 SET IN("APCDPROT")=$$GETPROT()
+13 IF LOC
Begin DoDot:1
+14 SET IN("HOS LOC")=LOC
+15 IF LOC=$$GET1^DIQ(9009033,$GET(PDIV),317,"I")
Begin DoDot:2
+16 SET IN("TIME RANGE")=0
+17 IF $GET(PRV)&PRF
SET IN("PROVIDER")=PRV
End DoDot:2
+18 IF '$TEST
Begin DoDot:2
+19 SET IN("TIME RANGE")=-1
+20 IF $GET(PRV)
SET IN("PROVIDER")=PRV
+21 ; IHS/MSC/PLS - 04/03/06
SET IN("ANCILLARY")=1
End DoDot:2
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 SET IN("TIME RANGE")=0
+24 SET IN("HOS LOC")=$$GET1^DIQ(9009033,$GET(PDIV),317,"I")
+25 IF $GET(PRV)&PRF
SET IN("PROVIDER")=PRV
End DoDot:1
+26 IF CAT="E"
KILL IN("HOS LOC")
+27 IF CRE<0
Begin DoDot:1
+28 SET IN("FORCE ADD")=1
+29 ; Force Create and return visit
SET IEN=$$MAKEVST(.IN)
End DoDot:1
QUIT IEN
+30 IF '$TEST
Begin DoDot:1
+31 IF 'CRE
KILL IN("ANCILLARY")
+32 SET IN("NEVER ADD")=1
+33 SET FVST=$$FNDVSTX(.IN)
End DoDot:1
+34 QUIT $SELECT(FVST:FVST,CRE>0:$$MAKEVST(.IN),1:0)
+35 ; Return whether an existing visit can be used or need to create one.
FNDVSTX(CRIT) ;
+1 NEW IEN,RET,EFLG
+2 SET RET=0
+3 DO GETVISIT^BSDAPI4(.CRIT,.OUT)
+4 ; No visits were found
IF 'OUT(0)
QUIT RET
+5 SET IEN=0
SET EFLG=0
+6 FOR
SET IEN=$ORDER(OUT(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+7 IF OUT(IEN)="ADD"
DO BRDCAST^CIANBEVT("PCC."_DFN_".VST",IEN)
+8 IF PRF
IF $$CKRXVST(IEN,13)
SET EFLG=1
SET RET=IEN
QUIT
+9 IF 'PRF
IF $$CKRXVST(IEN,13)
Begin DoDot:2
+10 KILL OUT(IEN)
+11 SET OUT(0)=OUT(0)-1
End DoDot:2
End DoDot:1
IF EFLG
QUIT
+12 QUIT $SELECT(RET:RET,OUT(0)=1:$ORDER(OUT(0)),1:$$ANCVCK(.OUT))
+13 ;
MAKEVST(CRIT) ;
+1 NEW RET,OUT
+2 KILL CRIT("NEVER ADD")
+3 SET CRIT("FORCE ADD")=1
+4 ;SET TO PHARMACY HOSPITAL LOCATION
SET CRIT("HOS LOC")=$SELECT(IN("SRV CAT")="E":"",LOC:+LOC,1:$$GET1^DIQ(9009033,$GET(PDIV),317,"I"))
+5 SET CRIT("CLINIC CODE")=$$GET1^DIQ(44,CRIT("HOS LOC"),8,"I")
+6 DO GETVISIT^BSDAPI4(.CRIT,.OUT)
+7 IF 'OUT(0)
QUIT OUT(0)
+8 SET RET=+$ORDER(OUT(0))
+9 IF OUT(RET)="ADD"
DO BRDCAST^CIANBEVT("PCC."_DFN_".VST",RET)
+10 QUIT RET
+11 ; Check visit for a Pharmacy visit (ancillary or paperless refill) and matching time
+12 ; Time is passed, Protocol and Option to Create are pharmacy options
CKRXVST(VIEN,TM) ; EP
+1 NEW PRT,OPT
+2 SET TM=$PIECE($$GET1^DIQ(9000010,VIEN,.01,"I"),".",2)=TM
+3 SET PRT=$$GET1^DIQ(9000010,VIEN,.25,"I")=$$GETPROT()
+4 SET OPT=$$GET1^DIQ(9000010,VIEN,.24,"I")=$$GETOPT()
+5 QUIT TM&PRT&OPT
+6 ; Check visits in array for existence of RX ancillary visit and return first ancillary visit
ANCVCK(VARY) ; EP
+1 ;Q 0
+2 NEW VIEN,RES
+3 SET RES=0
+4 SET VIEN=0
+5 FOR
SET VIEN=$ORDER(VARY(VIEN))
IF 'VIEN
QUIT
Begin DoDot:1
+6 IF $$CKRXVST(VIEN,12)
SET RES=VIEN
End DoDot:1
IF RES
QUIT
+7 QUIT RES
+8 ; Return absolute value
ABS(X) QUIT $SELECT(X<0:-X,1:X)
+1 ; Return a visit ien from a visit string (create if necessary)
+2 ; DFN = Patient IEN
+3 ; VSTR = Visit string (format: Hospital Location IEN or zero;Date of Service;Service Category;Visit IEN;outside med other location (- number = outside med, + number = other pharmacy)
+4 ; CREATE = Create flag
+5 ; 0 = Don't create
+6 ; >0 = Create if not found
+7 ; <0 = Always create
+8 ; PRV = Provider IEN to restrict visit search (optional)
+9 ; PDIV = Pharmacy Division (optional) Used for lookup of associated Hospital Location
+10 ; PRF = Paperless Refill Flag
VSTR2VIS(DFN,VSTR,CREATE,PRV,PDIV,PRF) ;EP
+1 NEW IEN,DAT,CAT,LOC,FLG,VSIT,LP,APCDALVR,TYP,OLOC,OSID
+2 SET LOC=+VSTR
SET DAT=+$PIECE(VSTR,";",2)
SET CAT=$PIECE(VSTR,";",3)
SET IEN=+$PIECE(VSTR,";",4)
SET CREATE=+$GET(CREATE)
+3 SET OLOC=$PIECE(VSTR,";",5)
SET TYP=$SELECT(OLOC:"O",1:"")
SET OSID=$PIECE(VSTR,";",6)
+4 IF 'IEN
SET IEN=$$FNDVIS(DFN,DAT,CAT,LOC,CREATE,.PRV,+$GET(PDIV),+$GET(PRF),TYP,OLOC,OSID)
+5 IF IEN>0
Begin DoDot:1
+6 SET VSTR=$GET(^AUPNVSIT(+IEN,0))
+7 IF '$LENGTH(VSTR)
SET IEN="-1^Visit does not exist"
+8 IF '$TEST
IF $PIECE(VSTR,U,5)'=DFN
SET IEN="-1^Visit does not belong to current patient"
+9 ; IHS/MSC/PLS - 10/31/06 - Correct issue with Hosp Loc piece
IF '$TEST
SET VSTR=$SELECT($PIECE(VSTR,U,22):$PIECE(VSTR,U,22),1:LOC)_";"_+VSTR_";"_$PIECE(VSTR,U,7)_";"_+IEN
End DoDot:1
+10 QUIT IEN
+11 ; Build PCC array
ADDPCC(X) ;
+1 IF '$DATA(PCC)
SET PCC(1)="HDR^^^"_VSTR
SET PCC(2)="VST^PT^"_DFN
+2 SET PCC($ORDER(PCC(""),-1)+1)=X
+3 QUIT
+4 ; Return Option IEN used to Create
GETOPT() ;EP
+1 NEW RET
+2 SET RET=$$FIND1^DIC(19,,"O","PSO LM BACKDOOR ORDERS")
+3 QUIT $SELECT(RET:RET,1:"")
+4 ; Return Protocol IEN used to Create
GETPROT() ;EP
+1 NEW RET
+2 SET RET=$$FIND1^DIC(101,,"O","IHS PS HOOK")
+3 QUIT $SELECT(RET:RET,1:"")
+4 ;
DELVSIT(VST) ;EP
+1 NEW APCDVLDT,U,APCDVFLE,AUPNVSIT,APCDVNM,APCDVDG,APCDVIGR,APCDVDFN
+2 NEW APCDVI,DIK,DA
+3 SET APCDVDLT=VST
+4 DO EN^APCDVDLT
+5 QUIT
AICD() ;EP
+1 QUIT $SELECT($$VERSION^XPDUTL("AICD")<"4.0":0,1:1)
