PSOERUT3 ;ALB/MFR - eRx Listman Allergy Utilities; 06/25/2022 5:14pm
;;7.0;OUTPATIENT PHARMACY;**700,746,770**;DEC 1997;Build 145
;
ALLERGY(MODE,NMSPC,ERXIEN,DFN) ; Sets Allergy and Adverse Reaction information
; Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
; NMSPC - ListMan Temp Global Namespace (e.g., "PSOERXP1")
; ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
; DFN - Pointer to PATIENT File(#2)
;
N IEN,X,XE,XV,LDAT,GMRAL,PSONOAL,LN,TYPE,VANOASS,VANKA,VERALLST,NOVALLST,REMALLST,VERARLST,NOVARLST,EALLDATA,ALLLN
N VALIST,ERXLIST,VA1ALL,VAALLS,ERX1ALL,ERXALLS,I,HDRLN,EALLLST,ENKA
Q:'$D(^PS(52.49,+$G(ERXIEN),0))
S (VERALLST,NOVALLST,VERARLST,NOVARLST,REMALLST)="",(VANOASS,VANKA)=0
I $G(DFN) D
. ; Allergies & Adverse Reactions
. S GMRA="0^0^111" D ^GMRADPT
. I GMRAL="" S VANOASS=1 Q ; No Allergy Assessment
. I GMRAL=0 S VANKA=1 Q ; No Known Allergies
. I GMRAL D ; Allergies Found
. . N ALL,Z,ALLLIST,VERIF,ALORAR,AGENT,AGENTX,FILE
. . S ALL=0 F S ALL=$O(GMRAL(ALL)) Q:'ALL D
. . . S Z=GMRAL(ALL),ALLLIST($S($P(Z,"^",4):"V",1:"NV"),$S('$P(Z,"^",5):"AL",1:"AR"),$P(Z,"^",2))=""
. . S (VERIF,ALORAR,AGENT)=""
. . F S VERIF=$O(ALLLIST(VERIF)) Q:VERIF="" D
. . . F S ALORAR=$O(ALLLIST(VERIF,ALORAR)) Q:ALORAR="" D
. . . . F S AGENT=$O(ALLLIST(VERIF,ALORAR,AGENT)) Q:AGENT="" D
. . . . . S AGENTX=AGENT I $L(AGENTX)>38 S AGENTX=$E(AGENTX,1,35)_"..."
. . . . . I VERIF="V",ALORAR="AL" S VERALLST=VERALLST_","_AGENTX
. . . . . I VERIF="NV",ALORAR="AL" S NOVALLST=NOVALLST_","_AGENTX
. . . . . I VERIF="V",ALORAR="AR" S VERARLST=VERARLST_","_AGENTX
. . . . . I VERIF="NV",ALORAR="AR" S NOVARLST=NOVARLST_","_AGENTX
. . . . . S VALIST($$UP^XLFSTR(AGENT))=""
. ; Remote Allergies
. I $T(HAVEHDR^ORRDI1)'="" D
. . I '$$HAVEHDR^ORRDI1 Q
. . I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) Q
. . I $T(GET^ORRDI1)]"" D GET^ORRDI1(DFN,"ART") D
. . . I $P($G(^XTMP("ORRDI","ART",DFN,0)),"^",3)=0 Q
. . . S ALL=0 F S ALL=$O(^XTMP("ORRDI","ART",DFN,ALL)) Q:'ALL D
. . . . S Z=$G(^XTMP("ORRDI","ART",DFN,ALL,"GMRALLERGY",0))
. . . . S AGENT=$P(Z,"^",2) Q:AGENT=""
. . . . S FILE=$P($P(Z,"^",3),"99VA",2)
. . . . I FILE'=50.6,FILE'=120.82,FILE'=50.605,FILE'=50.416 Q
. . . . S REMALLST=REMALLST_","_AGENT
. . . . S VALIST($$UP^XLFSTR(AGENT))=""
;
;Removing the last comma
S VERALLST=$$SORT^PSOERUT(VERALLST)
S NOVALLST=$$SORT^PSOERUT(NOVALLST)
S VERARLST=$$SORT^PSOERUT(VERARLST)
S NOVARLST=$$SORT^PSOERUT(NOVARLST)
S REMALLST=$$SORT^PSOERUT(REMALLST)
;
;eRx Allergies
S ENKA=$$GET1^DIQ(52.49,ERXIEN,302,"I")
; Retrieving the list of eRx Patient Allergies (Sorted Alphabetically)
D ALRGDATA^PSOERXU9(.EALLDATA,ERXIEN,1)
S EALLLST=",",SEQ=0 F S SEQ=$O(EALLDATA(SEQ)) Q:'SEQ D
. I $P(EALLDATA(SEQ),"^",7)="" Q
. S EALLLST=EALLLST_$E($$UP^XLFSTR($P(EALLDATA(SEQ),"^",7)),1,38)_","
. S ERXLIST($$UP^XLFSTR($P(EALLDATA(SEQ),"^",7)))=""
S $E(EALLLST)=""
;
K ERXLINES,VALINES
I ENKA="Y" D
. S ERXLINES(1,0)="NO KNOWN ALLERGIES"
I EALLLST'="" D
. S X=$$C2S^PSOERUT(EALLLST) K ^UTILITY($J,"W") S DIWL=1,DIWR=39,DIWF="|" D ^DIWP
. F I=1:1 Q:'$D(^UTILITY($J,"W",1,I)) S ERXLINES(I,0)=$$S2C^PSOERUT(^UTILITY($J,"W",1,I,0))
I ENKA'="Y",EALLLST="" D
. S ERXLINES(1,0)="NO ALLERGY INFORMATION RECEIVED"
;
; - VistA Allergies
I $G(DFN) D
. S LN=0 K HDRLN
. I VANOASS S LN=LN+1,VALINES(1,0)=" NO ALLERGY ASSESSMENT"
. I VANKA S LN=LN+1,VALINES(1,0)=" NO KNOWN ALLERGIES"
. I VERALLST'="" D
. . K ^UTILITY($J,"W")
. . S LN=LN+1,VALINES(LN,0)=" Verified:",HDRLN(LN)=1
. . S X=$$C2S^PSOERUT(VERALLST) K ^UTILITY($J,"W") S DIWL=1,DIWR=38,DIWF="|" D ^DIWP
. . F I=1:1 Q:'$D(^UTILITY($J,"W",1,I)) S LN=LN+1,VALINES(LN,0)=" "_$$S2C^PSOERUT(^UTILITY($J,"W",1,I,0))
. I NOVALLST'="" D
. . K ^UTILITY($J,"W")
. . S LN=LN+1,VALINES(LN,0)=" Non-Verified:",HDRLN(LN)=1
. . S X=$$C2S^PSOERUT(NOVALLST) K ^UTILITY($J,"W") S DIWL=1,DIWR=38,DIWF="|" D ^DIWP
. . F I=1:1 Q:'$D(^UTILITY($J,"W",1,I)) S LN=LN+1,VALINES(LN,0)=" "_$$S2C^PSOERUT(^UTILITY($J,"W",1,I,0))
. I REMALLST'="" D
. . K ^UTILITY($J,"W")
. . S LN=LN+1,VALINES(LN,0)="Remote Allergies:",HDRLN(LN)=0
. . S X=$$C2S^PSOERUT(REMALLST) K ^UTILITY($J,"W") S DIWL=1,DIWR=38,DIWF="|" D ^DIWP
. . F I=1:1 Q:'$D(^UTILITY($J,"W",1,I)) S LN=LN+1,VALINES(LN,0)=" "_$$S2C^PSOERUT(^UTILITY($J,"W",1,I,0))
. I (VERARLST'="")!(NOVARLST'="") D
. . S LN=LN+1,VALINES(LN,0)="Adverse Reactions:",HDRLN(LN)=0
. . I VERARLST'="" D
. . . S LN=LN+1,VALINES(LN,0)=" Verified:",HDRLN(LN)=1
. . . S X=$$C2S^PSOERUT(VERARLST) K ^UTILITY($J,"W") S DIWL=1,DIWR=38,DIWF="|" D ^DIWP
. . . F I=1:1 Q:'$D(^UTILITY($J,"W",1,I)) S LN=LN+1,VALINES(LN,0)=" "_$$S2C^PSOERUT(^UTILITY($J,"W",1,I,0))
. . I NOVARLST'="" D
. . . S LN=LN+1,VALINES(LN,0)=" Non-Verified:",HDRLN(LN)=1
. . . S X=$$C2S^PSOERUT(NOVARLST) K ^UTILITY($J,"W") S DIWL=1,DIWR=38,DIWF="|" D ^DIWP
. . . F I=1:1 Q:'$D(^UTILITY($J,"W",1,I)) S LN=LN+1,VALINES(LN,0)=" "_$$S2C^PSOERUT(^UTILITY($J,"W",1,I,0))
;
; - Setting eRx Allergies & Local VistA Allergies (Sets reverse video for non-matching
; Allergies between eRx and VistA)
S XE="Allergy:",XV="|Allergy:"
D ADDLINE^PSOERUT0(MODE,NMSPC,XE,XV)
F ALLLN=1:1 Q:('$D(ERXLINES(ALLLN))&'$D(VALINES(ALLLN))) D
. S ERXALLS=$G(ERXLINES(ALLLN,0)),VAALLS=$G(VALINES(ALLLN,0))
. I $D(VALIST)!$D(ERXLIST) D
. . F I=1:1:$L(ERXALLS,",") D
. . . S ERX1ALL=$P(ERXALLS,",",I)
. . . I ERX1ALL'="",'$D(VALIST(ERX1ALL)) D
. . . . S REVLN(LINE,$F(ERXALLS,ERX1ALL)-$L(ERX1ALL)+1)=$L(ERX1ALL)
. . . E S HIGHLN(LINE,$F(ERXALLS,ERX1ALL)-$L(ERX1ALL)+1)=$L(ERX1ALL)
. . I '$D(HDRLN(ALLLN)) D
. . . F I=1:1:$L(VAALLS,",") D
. . . . S VA1ALL=$P(VAALLS,",",I) S:$E(VA1ALL,1,2)=" " $E(VA1ALL,1,2)=""
. . . . I VA1ALL'="",'$D(ERXLIST(VA1ALL)) D
. . . . . S REVLN(LINE,40+$F(VAALLS,VA1ALL)-$L(VA1ALL))=$L(VA1ALL)
. . . . E S HIGHLN(LINE,40+$F(VAALLS,VA1ALL)-$L(VA1ALL))=$L(VA1ALL)
. . E S:$G(HDRLN(ALLLN)) UNDERLN(LINE,42)=$L(VAALLS)-1
. E D
. . I '$G(DFN)!(ENKA="Y"&VANKA) D
. . . S HIGHLN(LINE,2)=$L(ERXALLS),HIGHLN(LINE,42)=$L(VAALLS)
. . E S REVLN(LINE,2)=$L(ERXALLS) S REVLN(LINE,42)=$L(VAALLS)
. S XE=" "_$G(ERXLINES(ALLLN,0))
. S XV="|"_$G(VALINES(ALLLN,0))
. D ADDLINE^PSOERUT0(MODE,NMSPC,XE,XV)
Q
;
ADDALLS ; Add Alergies to the Screen (Reverses or Highlights Video for each Allergy)
N ALLLN
F ALLLN=1:1 Q:('$D(ERXLINES(ALLLN))&'$D(VALINES(ALLLN))) D
. S ERXALLS=$G(ERXLINES(ALLLN,0)),VAALLS=$E($G(VALINES(ALLLN,0)),2,99)
. I $D(VALIST)!$D(ERXLIST) D
. . F I=1:1:$L(ERXALLS,",") D
. . . S ERX1ALL=$P(ERXALLS,",",I)
. . . I ERX1ALL'="",'$D(VALIST(ERX1ALL)) D
. . . . S REVLN(LINE,$F(ERXALLS,ERX1ALL)-$L(ERX1ALL)+1)=$L(ERX1ALL)
. . . E S HIGHLN(LINE,$F(ERXALLS,ERX1ALL)-$L(ERX1ALL)+1)=$L(ERX1ALL)
. . I VAALLS'["erified:" D
. . . F I=1:1:$L(VAALLS,",") D
. . . . S VA1ALL=$P(VAALLS,",",I)
. . . . I VA1ALL'="",'$D(ERXLIST(VA1ALL)) D
. . . . . S REVLN(LINE,$F(VAALLS,VA1ALL)+42-$L(VA1ALL))=$L(VA1ALL)
. . . . E S HIGHLN(LINE,$F(VAALLS,VA1ALL)+42-$L(VA1ALL))=$L(VA1ALL)
. E D
. . I '$G(DFN)!(ENKA="Y"&VANKA) D
. . . S HIGHLN(LINE,2)=$L(ERXALLS),HIGHLN(LINE,42)=$L(VAALLS)+1
. . E S REVLN(LINE,2)=$L(ERXALLS) S REVLN(LINE,42)=$L(VAALLS)+1
. S XE=" "_$G(ERXLINES(ALLLN,0))
. S XV="| "_$G(VALINES(ALLLN,0))
. D ADDLINE^PSOERUT0(MODE,NMSPC,XE,XV)
Q
;
SETDIAGS(MODE,NMSPC,ERXIEN,CALLER) ; Sets Diagnosis and Indication For Use information
; Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
; NMSPC - ListMan Temp Global Namespace (e.g., "PSOERXP1")
; ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
; CALLER - Functionality calling this API ("SE":Single eRx View/Display;"VD":Validate Drug;"VP":Validate Patient;"PEN":Pending Order)
;
N DIAGS,DIAG,DIAGZ,XE,XV,INDCTN,OINDCTN,INDLBL,OINDLBL,INDLNE,XE,XEI,LMLINE,ERXLINES,XVI,VALINES,ALLLN
;Diagnosis
D GETDIAGS(ERXIEN,.DIAGS) S CALLER=$G(CALLER)
S XEI=0,LMLINE=LINE-1
I '$O(DIAGS(0)) D
. S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)="Primary Dx:"
E D
. S DIAG=0 F S DIAG=$O(DIAGS(DIAG)) Q:'DIAG D
. . S DIAGZ=DIAGS(DIAG)
. . S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)=$S($P(DIAGZ,"^")="P":"Primary",1:"Secondary")_" Dx:"
. . S XE=$P(DIAGZ,"^",2)_" "_$P(DIAGZ,"^",3)
. . F Q:$E(XE,1,38)="" D
. . . S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)=" "_$E(XE,1,38)
. . . S HIGUNDLN(LMLINE,2)=$L($E(XE,1,38))
. . . S XE=$E(XE,39,9999)
. . S XE=$P(DIAGZ,"^",4)
. . F Q:$E(XE,1,38)="" D
. . . S XEI=XEI+1,LMLINE=LMLINE+1,ERXLINES(XEI)=" "_$$COMPARE^PSOERUT0(MODE,$E(XE,1,38),$E(XE,1,38),2,,LMLINE)
. . . S XE=$E(XE,39,9999)
;Indications
I CALLER="VD"!(CALLER="SE") D
. S INDCTN=$$GET1^DIQ(52.49,ERXIEN,29)
. S OINDCTN=$$GET1^DIQ(52.49,ERXIEN,29.2)
. S XVI=0,LMLINE=LINE-1
. ;I CALLER="SE" S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" "
. S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=$S(CALLER="VD"!(CALLER="SE"):"11)",1:"")_"Indications:"
. I MODE="LM",CALLER="VD"!(CALLER="SE") S UNDERLN(LMLINE,41)=3
. I $G(INDCTN)'="" D
. . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$E(INDCTN,1,38),$E(INDCTN,1,38),42,,LMLINE)
. . I $L(INDCTN)>38 D
. . . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$E(INDCTN,39,99),$E(INDCTN,39,99),42,,LMLINE)
. I $G(OINDCTN)'="" D
. . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)="Other Indications:"
. . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$E(OINDCTN,1,38),$E(OINDCTN,1,38),42,,LMLINE)
. . I $L(OINDCTN)>38 D
. . . S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$E(OINDCTN,39,99),$E(OINDCTN,39,99),42,,LMLINE)
;Setting Diagnosis and Indications For Use
F ALLLN=1:1 Q:('$D(ERXLINES(ALLLN))&'$D(VALINES(ALLLN))) D
. S ERXALLS=$G(ERXLINES(ALLLN)),VAALLS=$G(VALINES(ALLLN))
. S XE=$G(ERXLINES(ALLLN))
. S XV="|"_$G(VALINES(ALLLN))
. D ADDLINE^PSOERUT0("LM",NMSPC,XE,XV)
;I ($D(VALINES)!$D(ERXLINES)) D BLANKLN^PSOERUT0(MODE)
Q
;
GETDIAGS(ERXIEN,ICDARR) ; Returns the diagnosis codes for the eRx order
; Input: (r) ERXIEN - Pointer to the ERX HOLDING QUEUE file (52.49)
;Output: ICDARR array - P1: "P"rimary or "S"econdary diagnosis | P2: Diagnosis qualifier" "Diagnosis code
; P3: ICD Description | P4: Primary or Secondary Diagnosis description
;
N MIEN,COUNT,DIAGIEN,DIENS,DIAGDAT,PDIAGQ,PDIAGV,PDESC,DRES,DRESL,DRESDAT
N SDIAGQ,SDIAGV,SDESC,SDRES,SDRESL,SDRESDAT
S (MIEN,COUNT)=0 F S MIEN=$O(^PS(52.49,ERXIEN,311,MIEN)) Q:'MIEN D
. S DIAGIEN=0 F S DIAGIEN=$O(^PS(52.49,ERXIEN,311,MIEN,3,DIAGIEN)) Q:'DIAGIEN D
. . S DIENS=DIAGIEN_","_MIEN_","_ERXIEN_"," N DIAGDAT
. . D GETS^DIQ(52.493113,DIENS,"**","IE","DIAGDAT")
. . S PDIAGQ=$G(DIAGDAT(52.493113,DIENS,1.2,"E"))
. . S PDIAGV=$G(DIAGDAT(52.493113,DIENS,1.1,"E"))
. . S PDESC=$G(DIAGDAT(52.493113,DIENS,2,"E"))
. . I PDIAGQ["ICD" D
. . . D ICDDESC^ICDXCODE(PDIAGQ,PDIAGV,,.DRES)
. . . I '$O(DRES(0)) D Q
. . . . S COUNT=COUNT+1,ICDARR(COUNT)="P^"_PDIAGQ_" "_PDIAGV_"^^"_PDESC
. . . S DRESL=0 F S DRESL=$O(DRES(DRESL)) Q:'DRESL D
. . . . S DRESDAT=$G(DRES(DRESL)) Q:DRESDAT=""
. . . . S COUNT=COUNT+1,ICDARR(COUNT)="P^"_PDIAGQ_" "_PDIAGV_"^"_$$UP^XLFSTR(DRESDAT)_"^"_PDESC
. . S SDIAGQ=$G(DIAGDAT(52.493113,DIENS,3.2,"E"))
. . S SDIAGV=$G(DIAGDAT(52.493113,DIENS,3.1,"E"))
. . S SDESC=$G(DIAGDAT(52.493113,DIENS,4,"E"))
. . I SDIAGQ["ICD" D
. . . D ICDDESC^ICDXCODE(SDIAGQ,SDIAGV,,.SDRES)
. . . I '$O(SDRES(0)) D Q
. . . . S COUNT=COUNT+1,ICDARR(COUNT)="S^"_SDIAGQ_" "_SDIAGV_"^^"_SDESC
. . . S SDRESL=0 F S SDRESL=$O(SDRES(SDRESL)) Q:'SDRESL D
. . . . S SDRESDAT=$G(SDRES(SDRESL)) Q:SDRESDAT=""
. . . . S COUNT=COUNT+1
. . . . S ICDARR(COUNT)="S^"_SDIAGQ_" "_SDIAGV_"^"_$$UP^XLFSTR(SDRESDAT)_"^"_SDESC
Q
;
SUGSIG(RXIEN,ERXIEN) ; Returns the Suggested SIG retrieved from the VA Rx
; Input:ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
; RXIEN - Prescription IEN - Pointer to PRESCRIPTION file (#52)
;Output:SUGSIG - Suggested SIG
;
K SUGSIG,VADOSE,SIG,I,VAPATIEN,PSODRUG,VAPATINS
I '$D(^PSRX(+$G(RXIEN),0))!'$D(^PS(52.49,+$G(ERXIEN),0)) Q ""
S PSODRUG("IEN")=+$$GET1^DIQ(52,RXIEN,6,"I"),PSODRUG("OI")=+$$GET1^DIQ(50,PSODRUG("IEN"),2.1,"I")
S SUGSIG=""
D VARXDOSE^PSOERUT4(RXIEN,.VADOSE)
K SIG D EN^PSOFSIG(.VADOSE)
F I=1:1 Q:'$D(SIG(I)) S SUGSIG=SUGSIG_SIG(I)
; - Appending Patient Instrutions
S VADRGIEN=+$$GET1^DIQ(52,RXIEN,6,"I")
S VAOIIEN=+$$GET1^DIQ(50,VADRGIEN,2.1,"I")
S VAPATIEN=+$$GET1^DIQ(52.49,ERXIEN,.05,"I")
S VAPATINS=$$VAPATINS(VAOIIEN,VAPATIEN)
I VAPATINS'="" S SUGSIG=SUGSIG_" "_VAPATINS
Q SUGSIG
;
VAPATINS(OI,DFN) ; Returns the Pharmacy Orderable Patient Instructions, if any
; Input: OI - Pointer to the PHARMACY ORDERABLE ITEM file (#50.7)
; (o)DFN - Pointer to the PATIEN file (#2)
;Output: VAPTINS - Expanded (if needed) OI Patient Instructions
;
N VAPATINS,FLD,X,PSODIR,INS1
S FLD=7
I $G(DFN),$$GET1^DIQ(55,DFN,106,"I") S FLD=7.1
S VAPATINS=$$GET1^DIQ(50.7,+$G(OI),FLD)
;
I $G(VAPATINS)'="" D
. S (X,PSODIR("INS"))=VAPATINS D SIG^PSOHELP S $E(INS1)="",VAPATINS=INS1
Q VAPATINS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERUT3 13452 printed Aug 26, 2025@22:44:09 Page 2
PSOERUT3 ;ALB/MFR - eRx Listman Allergy Utilities; 06/25/2022 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**700,746,770**;DEC 1997;Build 145
+2 ;
ALLERGY(MODE,NMSPC,ERXIEN,DFN) ; Sets Allergy and Adverse Reaction information
+1 ; Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
+2 ; NMSPC - ListMan Temp Global Namespace (e.g., "PSOERXP1")
+3 ; ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+4 ; DFN - Pointer to PATIENT File(#2)
+5 ;
+6 NEW IEN,X,XE,XV,LDAT,GMRAL,PSONOAL,LN,TYPE,VANOASS,VANKA,VERALLST,NOVALLST,REMALLST,VERARLST,NOVARLST,EALLDATA,ALLLN
+7 NEW VALIST,ERXLIST,VA1ALL,VAALLS,ERX1ALL,ERXALLS,I,HDRLN,EALLLST,ENKA
+8 if '$DATA(^PS(52.49,+$GET(ERXIEN),0))
QUIT
+9 SET (VERALLST,NOVALLST,VERARLST,NOVARLST,REMALLST)=""
SET (VANOASS,VANKA)=0
+10 IF $GET(DFN)
Begin DoDot:1
+11 ; Allergies & Adverse Reactions
+12 SET GMRA="0^0^111"
DO ^GMRADPT
+13 ; No Allergy Assessment
IF GMRAL=""
SET VANOASS=1
QUIT
+14 ; No Known Allergies
IF GMRAL=0
SET VANKA=1
QUIT
+15 ; Allergies Found
IF GMRAL
Begin DoDot:2
+16 NEW ALL,Z,ALLLIST,VERIF,ALORAR,AGENT,AGENTX,FILE
+17 SET ALL=0
FOR
SET ALL=$ORDER(GMRAL(ALL))
if 'ALL
QUIT
Begin DoDot:3
+18 SET Z=GMRAL(ALL)
SET ALLLIST($SELECT($PIECE(Z,"^",4):"V",1:"NV"),$SELECT('$PIECE(Z,"^",5):"AL",1:"AR"),$PIECE(Z,"^",2))=""
End DoDot:3
+19 SET (VERIF,ALORAR,AGENT)=""
+20 FOR
SET VERIF=$ORDER(ALLLIST(VERIF))
if VERIF=""
QUIT
Begin DoDot:3
+21 FOR
SET ALORAR=$ORDER(ALLLIST(VERIF,ALORAR))
if ALORAR=""
QUIT
Begin DoDot:4
+22 FOR
SET AGENT=$ORDER(ALLLIST(VERIF,ALORAR,AGENT))
if AGENT=""
QUIT
Begin DoDot:5
+23 SET AGENTX=AGENT
IF $LENGTH(AGENTX)>38
SET AGENTX=$EXTRACT(AGENTX,1,35)_"..."
+24 IF VERIF="V"
IF ALORAR="AL"
SET VERALLST=VERALLST_","_AGENTX
+25 IF VERIF="NV"
IF ALORAR="AL"
SET NOVALLST=NOVALLST_","_AGENTX
+26 IF VERIF="V"
IF ALORAR="AR"
SET VERARLST=VERARLST_","_AGENTX
+27 IF VERIF="NV"
IF ALORAR="AR"
SET NOVARLST=NOVARLST_","_AGENTX
+28 SET VALIST($$UP^XLFSTR(AGENT))=""
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+29 ; Remote Allergies
+30 IF $TEXT(HAVEHDR^ORRDI1)'=""
Begin DoDot:2
+31 IF '$$HAVEHDR^ORRDI1
QUIT
+32 IF $DATA(^XTMP("ORRDI","OUTAGE INFO","DOWN"))
QUIT
+33 IF $TEXT(GET^ORRDI1)]""
DO GET^ORRDI1(DFN,"ART")
Begin DoDot:3
+34 IF $PIECE($GET(^XTMP("ORRDI","ART",DFN,0)),"^",3)=0
QUIT
+35 SET ALL=0
FOR
SET ALL=$ORDER(^XTMP("ORRDI","ART",DFN,ALL))
if 'ALL
QUIT
Begin DoDot:4
+36 SET Z=$GET(^XTMP("ORRDI","ART",DFN,ALL,"GMRALLERGY",0))
+37 SET AGENT=$PIECE(Z,"^",2)
if AGENT=""
QUIT
+38 SET FILE=$PIECE($PIECE(Z,"^",3),"99VA",2)
+39 IF FILE'=50.6
IF FILE'=120.82
IF FILE'=50.605
IF FILE'=50.416
QUIT
+40 SET REMALLST=REMALLST_","_AGENT
+41 SET VALIST($$UP^XLFSTR(AGENT))=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+42 ;
+43 ;Removing the last comma
+44 SET VERALLST=$$SORT^PSOERUT(VERALLST)
+45 SET NOVALLST=$$SORT^PSOERUT(NOVALLST)
+46 SET VERARLST=$$SORT^PSOERUT(VERARLST)
+47 SET NOVARLST=$$SORT^PSOERUT(NOVARLST)
+48 SET REMALLST=$$SORT^PSOERUT(REMALLST)
+49 ;
+50 ;eRx Allergies
+51 SET ENKA=$$GET1^DIQ(52.49,ERXIEN,302,"I")
+52 ; Retrieving the list of eRx Patient Allergies (Sorted Alphabetically)
+53 DO ALRGDATA^PSOERXU9(.EALLDATA,ERXIEN,1)
+54 SET EALLLST=","
SET SEQ=0
FOR
SET SEQ=$ORDER(EALLDATA(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+55 IF $PIECE(EALLDATA(SEQ),"^",7)=""
QUIT
+56 SET EALLLST=EALLLST_$EXTRACT($$UP^XLFSTR($PIECE(EALLDATA(SEQ),"^",7)),1,38)_","
+57 SET ERXLIST($$UP^XLFSTR($PIECE(EALLDATA(SEQ),"^",7)))=""
End DoDot:1
+58 SET $EXTRACT(EALLLST)=""
+59 ;
+60 KILL ERXLINES,VALINES
+61 IF ENKA="Y"
Begin DoDot:1
+62 SET ERXLINES(1,0)="NO KNOWN ALLERGIES"
End DoDot:1
+63 IF EALLLST'=""
Begin DoDot:1
+64 SET X=$$C2S^PSOERUT(EALLLST)
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=39
SET DIWF="|"
DO ^DIWP
+65 FOR I=1:1
if '$DATA(^UTILITY($JOB,"W",1,I))
QUIT
SET ERXLINES(I,0)=$$S2C^PSOERUT(^UTILITY($JOB,"W",1,I,0))
End DoDot:1
+66 IF ENKA'="Y"
IF EALLLST=""
Begin DoDot:1
+67 SET ERXLINES(1,0)="NO ALLERGY INFORMATION RECEIVED"
End DoDot:1
+68 ;
+69 ; - VistA Allergies
+70 IF $GET(DFN)
Begin DoDot:1
+71 SET LN=0
KILL HDRLN
+72 IF VANOASS
SET LN=LN+1
SET VALINES(1,0)=" NO ALLERGY ASSESSMENT"
+73 IF VANKA
SET LN=LN+1
SET VALINES(1,0)=" NO KNOWN ALLERGIES"
+74 IF VERALLST'=""
Begin DoDot:2
+75 KILL ^UTILITY($JOB,"W")
+76 SET LN=LN+1
SET VALINES(LN,0)=" Verified:"
SET HDRLN(LN)=1
+77 SET X=$$C2S^PSOERUT(VERALLST)
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=38
SET DIWF="|"
DO ^DIWP
+78 FOR I=1:1
if '$DATA(^UTILITY($JOB,"W",1,I))
QUIT
SET LN=LN+1
SET VALINES(LN,0)=" "_$$S2C^PSOERUT(^UTILITY($JOB,"W",1,I,0))
End DoDot:2
+79 IF NOVALLST'=""
Begin DoDot:2
+80 KILL ^UTILITY($JOB,"W")
+81 SET LN=LN+1
SET VALINES(LN,0)=" Non-Verified:"
SET HDRLN(LN)=1
+82 SET X=$$C2S^PSOERUT(NOVALLST)
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=38
SET DIWF="|"
DO ^DIWP
+83 FOR I=1:1
if '$DATA(^UTILITY($JOB,"W",1,I))
QUIT
SET LN=LN+1
SET VALINES(LN,0)=" "_$$S2C^PSOERUT(^UTILITY($JOB,"W",1,I,0))
End DoDot:2
+84 IF REMALLST'=""
Begin DoDot:2
+85 KILL ^UTILITY($JOB,"W")
+86 SET LN=LN+1
SET VALINES(LN,0)="Remote Allergies:"
SET HDRLN(LN)=0
+87 SET X=$$C2S^PSOERUT(REMALLST)
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=38
SET DIWF="|"
DO ^DIWP
+88 FOR I=1:1
if '$DATA(^UTILITY($JOB,"W",1,I))
QUIT
SET LN=LN+1
SET VALINES(LN,0)=" "_$$S2C^PSOERUT(^UTILITY($JOB,"W",1,I,0))
End DoDot:2
+89 IF (VERARLST'="")!(NOVARLST'="")
Begin DoDot:2
+90 SET LN=LN+1
SET VALINES(LN,0)="Adverse Reactions:"
SET HDRLN(LN)=0
+91 IF VERARLST'=""
Begin DoDot:3
+92 SET LN=LN+1
SET VALINES(LN,0)=" Verified:"
SET HDRLN(LN)=1
+93 SET X=$$C2S^PSOERUT(VERARLST)
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=38
SET DIWF="|"
DO ^DIWP
+94 FOR I=1:1
if '$DATA(^UTILITY($JOB,"W",1,I))
QUIT
SET LN=LN+1
SET VALINES(LN,0)=" "_$$S2C^PSOERUT(^UTILITY($JOB,"W",1,I,0))
End DoDot:3
+95 IF NOVARLST'=""
Begin DoDot:3
+96 SET LN=LN+1
SET VALINES(LN,0)=" Non-Verified:"
SET HDRLN(LN)=1
+97 SET X=$$C2S^PSOERUT(NOVARLST)
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=38
SET DIWF="|"
DO ^DIWP
+98 FOR I=1:1
if '$DATA(^UTILITY($JOB,"W",1,I))
QUIT
SET LN=LN+1
SET VALINES(LN,0)=" "_$$S2C^PSOERUT(^UTILITY($JOB,"W",1,I,0))
End DoDot:3
End DoDot:2
End DoDot:1
+99 ;
+100 ; - Setting eRx Allergies & Local VistA Allergies (Sets reverse video for non-matching
+101 ; Allergies between eRx and VistA)
+102 SET XE="Allergy:"
SET XV="|Allergy:"
+103 DO ADDLINE^PSOERUT0(MODE,NMSPC,XE,XV)
+104 FOR ALLLN=1:1
if ('$DATA(ERXLINES(ALLLN))&'$DATA(VALINES(ALLLN)))
QUIT
Begin DoDot:1
+105 SET ERXALLS=$GET(ERXLINES(ALLLN,0))
SET VAALLS=$GET(VALINES(ALLLN,0))
+106 IF $DATA(VALIST)!$DATA(ERXLIST)
Begin DoDot:2
+107 FOR I=1:1:$LENGTH(ERXALLS,",")
Begin DoDot:3
+108 SET ERX1ALL=$PIECE(ERXALLS,",",I)
+109 IF ERX1ALL'=""
IF '$DATA(VALIST(ERX1ALL))
Begin DoDot:4
+110 SET REVLN(LINE,$FIND(ERXALLS,ERX1ALL)-$LENGTH(ERX1ALL)+1)=$LENGTH(ERX1ALL)
End DoDot:4
+111 IF '$TEST
SET HIGHLN(LINE,$FIND(ERXALLS,ERX1ALL)-$LENGTH(ERX1ALL)+1)=$LENGTH(ERX1ALL)
End DoDot:3
+112 IF '$DATA(HDRLN(ALLLN))
Begin DoDot:3
+113 FOR I=1:1:$LENGTH(VAALLS,",")
Begin DoDot:4
+114 SET VA1ALL=$PIECE(VAALLS,",",I)
if $EXTRACT(VA1ALL,1,2)=" "
SET $EXTRACT(VA1ALL,1,2)=""
+115 IF VA1ALL'=""
IF '$DATA(ERXLIST(VA1ALL))
Begin DoDot:5
+116 SET REVLN(LINE,40+$FIND(VAALLS,VA1ALL)-$LENGTH(VA1ALL))=$LENGTH(VA1ALL)
End DoDot:5
+117 IF '$TEST
SET HIGHLN(LINE,40+$FIND(VAALLS,VA1ALL)-$LENGTH(VA1ALL))=$LENGTH(VA1ALL)
End DoDot:4
End DoDot:3
+118 IF '$TEST
if $GET(HDRLN(ALLLN))
SET UNDERLN(LINE,42)=$LENGTH(VAALLS)-1
End DoDot:2
+119 IF '$TEST
Begin DoDot:2
+120 IF '$GET(DFN)!(ENKA="Y"&VANKA)
Begin DoDot:3
+121 SET HIGHLN(LINE,2)=$LENGTH(ERXALLS)
SET HIGHLN(LINE,42)=$LENGTH(VAALLS)
End DoDot:3
+122 IF '$TEST
SET REVLN(LINE,2)=$LENGTH(ERXALLS)
SET REVLN(LINE,42)=$LENGTH(VAALLS)
End DoDot:2
+123 SET XE=" "_$GET(ERXLINES(ALLLN,0))
+124 SET XV="|"_$GET(VALINES(ALLLN,0))
+125 DO ADDLINE^PSOERUT0(MODE,NMSPC,XE,XV)
End DoDot:1
+126 QUIT
+127 ;
ADDALLS ; Add Alergies to the Screen (Reverses or Highlights Video for each Allergy)
+1 NEW ALLLN
+2 FOR ALLLN=1:1
if ('$DATA(ERXLINES(ALLLN))&'$DATA(VALINES(ALLLN)))
QUIT
Begin DoDot:1
+3 SET ERXALLS=$GET(ERXLINES(ALLLN,0))
SET VAALLS=$EXTRACT($GET(VALINES(ALLLN,0)),2,99)
+4 IF $DATA(VALIST)!$DATA(ERXLIST)
Begin DoDot:2
+5 FOR I=1:1:$LENGTH(ERXALLS,",")
Begin DoDot:3
+6 SET ERX1ALL=$PIECE(ERXALLS,",",I)
+7 IF ERX1ALL'=""
IF '$DATA(VALIST(ERX1ALL))
Begin DoDot:4
+8 SET REVLN(LINE,$FIND(ERXALLS,ERX1ALL)-$LENGTH(ERX1ALL)+1)=$LENGTH(ERX1ALL)
End DoDot:4
+9 IF '$TEST
SET HIGHLN(LINE,$FIND(ERXALLS,ERX1ALL)-$LENGTH(ERX1ALL)+1)=$LENGTH(ERX1ALL)
End DoDot:3
+10 IF VAALLS'["erified:"
Begin DoDot:3
+11 FOR I=1:1:$LENGTH(VAALLS,",")
Begin DoDot:4
+12 SET VA1ALL=$PIECE(VAALLS,",",I)
+13 IF VA1ALL'=""
IF '$DATA(ERXLIST(VA1ALL))
Begin DoDot:5
+14 SET REVLN(LINE,$FIND(VAALLS,VA1ALL)+42-$LENGTH(VA1ALL))=$LENGTH(VA1ALL)
End DoDot:5
+15 IF '$TEST
SET HIGHLN(LINE,$FIND(VAALLS,VA1ALL)+42-$LENGTH(VA1ALL))=$LENGTH(VA1ALL)
End DoDot:4
End DoDot:3
End DoDot:2
+16 IF '$TEST
Begin DoDot:2
+17 IF '$GET(DFN)!(ENKA="Y"&VANKA)
Begin DoDot:3
+18 SET HIGHLN(LINE,2)=$LENGTH(ERXALLS)
SET HIGHLN(LINE,42)=$LENGTH(VAALLS)+1
End DoDot:3
+19 IF '$TEST
SET REVLN(LINE,2)=$LENGTH(ERXALLS)
SET REVLN(LINE,42)=$LENGTH(VAALLS)+1
End DoDot:2
+20 SET XE=" "_$GET(ERXLINES(ALLLN,0))
+21 SET XV="| "_$GET(VALINES(ALLLN,0))
+22 DO ADDLINE^PSOERUT0(MODE,NMSPC,XE,XV)
End DoDot:1
+23 QUIT
+24 ;
SETDIAGS(MODE,NMSPC,ERXIEN,CALLER) ; Sets Diagnosis and Indication For Use information
+1 ; Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
+2 ; NMSPC - ListMan Temp Global Namespace (e.g., "PSOERXP1")
+3 ; ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+4 ; CALLER - Functionality calling this API ("SE":Single eRx View/Display;"VD":Validate Drug;"VP":Validate Patient;"PEN":Pending Order)
+5 ;
+6 NEW DIAGS,DIAG,DIAGZ,XE,XV,INDCTN,OINDCTN,INDLBL,OINDLBL,INDLNE,XE,XEI,LMLINE,ERXLINES,XVI,VALINES,ALLLN
+7 ;Diagnosis
+8 DO GETDIAGS(ERXIEN,.DIAGS)
SET CALLER=$GET(CALLER)
+9 SET XEI=0
SET LMLINE=LINE-1
+10 IF '$ORDER(DIAGS(0))
Begin DoDot:1
+11 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)="Primary Dx:"
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET DIAG=0
FOR
SET DIAG=$ORDER(DIAGS(DIAG))
if 'DIAG
QUIT
Begin DoDot:2
+14 SET DIAGZ=DIAGS(DIAG)
+15 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)=$SELECT($PIECE(DIAGZ,"^")="P":"Primary",1:"Secondary")_" Dx:"
+16 SET XE=$PIECE(DIAGZ,"^",2)_" "_$PIECE(DIAGZ,"^",3)
+17 FOR
if $EXTRACT(XE,1,38)=""
QUIT
Begin DoDot:3
+18 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)=" "_$EXTRACT(XE,1,38)
+19 SET HIGUNDLN(LMLINE,2)=$LENGTH($EXTRACT(XE,1,38))
+20 SET XE=$EXTRACT(XE,39,9999)
End DoDot:3
+21 SET XE=$PIECE(DIAGZ,"^",4)
+22 FOR
if $EXTRACT(XE,1,38)=""
QUIT
Begin DoDot:3
+23 SET XEI=XEI+1
SET LMLINE=LMLINE+1
SET ERXLINES(XEI)=" "_$$COMPARE^PSOERUT0(MODE,$EXTRACT(XE,1,38),$EXTRACT(XE,1,38),2,,LMLINE)
+24 SET XE=$EXTRACT(XE,39,9999)
End DoDot:3
End DoDot:2
End DoDot:1
+25 ;Indications
+26 IF CALLER="VD"!(CALLER="SE")
Begin DoDot:1
+27 SET INDCTN=$$GET1^DIQ(52.49,ERXIEN,29)
+28 SET OINDCTN=$$GET1^DIQ(52.49,ERXIEN,29.2)
+29 SET XVI=0
SET LMLINE=LINE-1
+30 ;I CALLER="SE" S XVI=XVI+1,LMLINE=LMLINE+1,VALINES(XVI)=" "
+31 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=$SELECT(CALLER="VD"!(CALLER="SE"):"11)",1:"")_"Indications:"
+32 IF MODE="LM"
IF CALLER="VD"!(CALLER="SE")
SET UNDERLN(LMLINE,41)=3
+33 IF $GET(INDCTN)'=""
Begin DoDot:2
+34 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$EXTRACT(INDCTN,1,38),$EXTRACT(INDCTN,1,38),42,,LMLINE)
+35 IF $LENGTH(INDCTN)>38
Begin DoDot:3
+36 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$EXTRACT(INDCTN,39,99),$EXTRACT(INDCTN,39,99),42,,LMLINE)
End DoDot:3
End DoDot:2
+37 IF $GET(OINDCTN)'=""
Begin DoDot:2
+38 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)="Other Indications:"
+39 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$EXTRACT(OINDCTN,1,38),$EXTRACT(OINDCTN,1,38),42,,LMLINE)
+40 IF $LENGTH(OINDCTN)>38
Begin DoDot:3
+41 SET XVI=XVI+1
SET LMLINE=LMLINE+1
SET VALINES(XVI)=" "_$$COMPARE^PSOERUT0("LM",$EXTRACT(OINDCTN,39,99),$EXTRACT(OINDCTN,39,99),42,,LMLINE)
End DoDot:3
End DoDot:2
End DoDot:1
+42 ;Setting Diagnosis and Indications For Use
+43 FOR ALLLN=1:1
if ('$DATA(ERXLINES(ALLLN))&'$DATA(VALINES(ALLLN)))
QUIT
Begin DoDot:1
+44 SET ERXALLS=$GET(ERXLINES(ALLLN))
SET VAALLS=$GET(VALINES(ALLLN))
+45 SET XE=$GET(ERXLINES(ALLLN))
+46 SET XV="|"_$GET(VALINES(ALLLN))
+47 DO ADDLINE^PSOERUT0("LM",NMSPC,XE,XV)
End DoDot:1
+48 ;I ($D(VALINES)!$D(ERXLINES)) D BLANKLN^PSOERUT0(MODE)
+49 QUIT
+50 ;
GETDIAGS(ERXIEN,ICDARR) ; Returns the diagnosis codes for the eRx order
+1 ; Input: (r) ERXIEN - Pointer to the ERX HOLDING QUEUE file (52.49)
+2 ;Output: ICDARR array - P1: "P"rimary or "S"econdary diagnosis | P2: Diagnosis qualifier" "Diagnosis code
+3 ; P3: ICD Description | P4: Primary or Secondary Diagnosis description
+4 ;
+5 NEW MIEN,COUNT,DIAGIEN,DIENS,DIAGDAT,PDIAGQ,PDIAGV,PDESC,DRES,DRESL,DRESDAT
+6 NEW SDIAGQ,SDIAGV,SDESC,SDRES,SDRESL,SDRESDAT
+7 SET (MIEN,COUNT)=0
FOR
SET MIEN=$ORDER(^PS(52.49,ERXIEN,311,MIEN))
if 'MIEN
QUIT
Begin DoDot:1
+8 SET DIAGIEN=0
FOR
SET DIAGIEN=$ORDER(^PS(52.49,ERXIEN,311,MIEN,3,DIAGIEN))
if 'DIAGIEN
QUIT
Begin DoDot:2
+9 SET DIENS=DIAGIEN_","_MIEN_","_ERXIEN_","
NEW DIAGDAT
+10 DO GETS^DIQ(52.493113,DIENS,"**","IE","DIAGDAT")
+11 SET PDIAGQ=$GET(DIAGDAT(52.493113,DIENS,1.2,"E"))
+12 SET PDIAGV=$GET(DIAGDAT(52.493113,DIENS,1.1,"E"))
+13 SET PDESC=$GET(DIAGDAT(52.493113,DIENS,2,"E"))
+14 IF PDIAGQ["ICD"
Begin DoDot:3
+15 DO ICDDESC^ICDXCODE(PDIAGQ,PDIAGV,,.DRES)
+16 IF '$ORDER(DRES(0))
Begin DoDot:4
+17 SET COUNT=COUNT+1
SET ICDARR(COUNT)="P^"_PDIAGQ_" "_PDIAGV_"^^"_PDESC
End DoDot:4
QUIT
+18 SET DRESL=0
FOR
SET DRESL=$ORDER(DRES(DRESL))
if 'DRESL
QUIT
Begin DoDot:4
+19 SET DRESDAT=$GET(DRES(DRESL))
if DRESDAT=""
QUIT
+20 SET COUNT=COUNT+1
SET ICDARR(COUNT)="P^"_PDIAGQ_" "_PDIAGV_"^"_$$UP^XLFSTR(DRESDAT)_"^"_PDESC
End DoDot:4
End DoDot:3
+21 SET SDIAGQ=$GET(DIAGDAT(52.493113,DIENS,3.2,"E"))
+22 SET SDIAGV=$GET(DIAGDAT(52.493113,DIENS,3.1,"E"))
+23 SET SDESC=$GET(DIAGDAT(52.493113,DIENS,4,"E"))
+24 IF SDIAGQ["ICD"
Begin DoDot:3
+25 DO ICDDESC^ICDXCODE(SDIAGQ,SDIAGV,,.SDRES)
+26 IF '$ORDER(SDRES(0))
Begin DoDot:4
+27 SET COUNT=COUNT+1
SET ICDARR(COUNT)="S^"_SDIAGQ_" "_SDIAGV_"^^"_SDESC
End DoDot:4
QUIT
+28 SET SDRESL=0
FOR
SET SDRESL=$ORDER(SDRES(SDRESL))
if 'SDRESL
QUIT
Begin DoDot:4
+29 SET SDRESDAT=$GET(SDRES(SDRESL))
if SDRESDAT=""
QUIT
+30 SET COUNT=COUNT+1
+31 SET ICDARR(COUNT)="S^"_SDIAGQ_" "_SDIAGV_"^"_$$UP^XLFSTR(SDRESDAT)_"^"_SDESC
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
SUGSIG(RXIEN,ERXIEN) ; Returns the Suggested SIG retrieved from the VA Rx
+1 ; Input:ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+2 ; RXIEN - Prescription IEN - Pointer to PRESCRIPTION file (#52)
+3 ;Output:SUGSIG - Suggested SIG
+4 ;
+5 KILL SUGSIG,VADOSE,SIG,I,VAPATIEN,PSODRUG,VAPATINS
+6 IF '$DATA(^PSRX(+$GET(RXIEN),0))!'$DATA(^PS(52.49,+$GET(ERXIEN),0))
QUIT ""
+7 SET PSODRUG("IEN")=+$$GET1^DIQ(52,RXIEN,6,"I")
SET PSODRUG("OI")=+$$GET1^DIQ(50,PSODRUG("IEN"),2.1,"I")
+8 SET SUGSIG=""
+9 DO VARXDOSE^PSOERUT4(RXIEN,.VADOSE)
+10 KILL SIG
DO EN^PSOFSIG(.VADOSE)
+11 FOR I=1:1
if '$DATA(SIG(I))
QUIT
SET SUGSIG=SUGSIG_SIG(I)
+12 ; - Appending Patient Instrutions
+13 SET VADRGIEN=+$$GET1^DIQ(52,RXIEN,6,"I")
+14 SET VAOIIEN=+$$GET1^DIQ(50,VADRGIEN,2.1,"I")
+15 SET VAPATIEN=+$$GET1^DIQ(52.49,ERXIEN,.05,"I")
+16 SET VAPATINS=$$VAPATINS(VAOIIEN,VAPATIEN)
+17 IF VAPATINS'=""
SET SUGSIG=SUGSIG_" "_VAPATINS
+18 QUIT SUGSIG
+19 ;
VAPATINS(OI,DFN) ; Returns the Pharmacy Orderable Patient Instructions, if any
+1 ; Input: OI - Pointer to the PHARMACY ORDERABLE ITEM file (#50.7)
+2 ; (o)DFN - Pointer to the PATIEN file (#2)
+3 ;Output: VAPTINS - Expanded (if needed) OI Patient Instructions
+4 ;
+5 NEW VAPATINS,FLD,X,PSODIR,INS1
+6 SET FLD=7
+7 IF $GET(DFN)
IF $$GET1^DIQ(55,DFN,106,"I")
SET FLD=7.1
+8 SET VAPATINS=$$GET1^DIQ(50.7,+$GET(OI),FLD)
+9 ;
+10 IF $GET(VAPATINS)'=""
Begin DoDot:1
+11 SET (X,PSODIR("INS"))=VAPATINS
DO SIG^PSOHELP
SET $EXTRACT(INS1)=""
SET VAPATINS=INS1
End DoDot:1
+12 QUIT VAPATINS
