APSPPCCV.m

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