PSOERUT3 ;ALB/MFR - eRx Listman Allergy Utilities; 06/25/2022 5:14pm
;;7.0;OUTPATIENT PHARMACY;**700,746**;DEC 1997;Build 106
;
ALLERGY(MODE,NPSPC,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,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
. . . . . I VERIF="V",ALORAR="AL" S VERALLST=VERALLST_","_AGENT
. . . . . I VERIF="NV",ALORAR="AL" S NOVALLST=NOVALLST_","_AGENT
. . . . . I VERIF="V",ALORAR="AR" S VERARLST=VERARLST_","_AGENT
. . . . . I VERIF="NV",ALORAR="AR" S NOVARLST=NOVARLST_","_AGENT
. . . . . 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($P(EALLDATA(SEQ),"^",7),1,38)_","
. S ERXLIST($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)
D BLANKLN^PSOERUT0(MODE),VIDEO^PSOERUT0()
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,NPSPC,ERXIEN) ; Sets Diagnosis 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)
N DIAGS,DIAG,DIAGZ,XE
D GETDIAGS(ERXIEN,.DIAGS)
S DIAG=0 F S DIAG=$O(DIAGS(DIAG)) Q:'DIAG D
. S DIAGZ=DIAGS(DIAG)
. S XE=$S($P(DIAGZ,"^")="P":"Primary",1:"Secondary")_" Dx:" D ADDLINE^PSOERUT0(MODE,NMSPC,XE,"|")
. S XE=$P(DIAGZ,"^",2)_" "_$P(DIAGZ,"^",3)
. F Q:$E(XE,1,38)="" D
. . S HIGUNDLN(LINE,2)=$L($E(XE,1,38))
. . D ADDLINE^PSOERUT0(MODE,NMSPC," "_$E(XE,1,38),"|")
. . S XE=$E(XE,39,9999)
. S XE=$P(DIAGZ,"^",4)
. F Q:$E(XE,1,38)="" D
. . D ADDLINE^PSOERUT0(MODE,NMSPC," "_$$COMPARE^PSOERUT0(MODE,$E(XE,1,38),$E(XE,1,38),2),"|")
. . S XE=$E(XE,39,9999)
I $O(DIAGS(0)) 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 11596 printed Dec 13, 2024@02:28:04 Page 2
PSOERUT3 ;ALB/MFR - eRx Listman Allergy Utilities; 06/25/2022 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**700,746**;DEC 1997;Build 106
+2 ;
ALLERGY(MODE,NPSPC,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,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 IF VERIF="V"
IF ALORAR="AL"
SET VERALLST=VERALLST_","_AGENT
+24 IF VERIF="NV"
IF ALORAR="AL"
SET NOVALLST=NOVALLST_","_AGENT
+25 IF VERIF="V"
IF ALORAR="AR"
SET VERARLST=VERARLST_","_AGENT
+26 IF VERIF="NV"
IF ALORAR="AR"
SET NOVARLST=NOVARLST_","_AGENT
+27 SET VALIST($$UP^XLFSTR(AGENT))=""
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+28 ; Remote Allergies
+29 IF $TEXT(HAVEHDR^ORRDI1)'=""
Begin DoDot:2
+30 IF '$$HAVEHDR^ORRDI1
QUIT
+31 IF $DATA(^XTMP("ORRDI","OUTAGE INFO","DOWN"))
QUIT
+32 IF $TEXT(GET^ORRDI1)]""
DO GET^ORRDI1(DFN,"ART")
Begin DoDot:3
+33 IF $PIECE($GET(^XTMP("ORRDI","ART",DFN,0)),"^",3)=0
QUIT
+34 SET ALL=0
FOR
SET ALL=$ORDER(^XTMP("ORRDI","ART",DFN,ALL))
if 'ALL
QUIT
Begin DoDot:4
+35 SET Z=$GET(^XTMP("ORRDI","ART",DFN,ALL,"GMRALLERGY",0))
+36 SET AGENT=$PIECE(Z,"^",2)
if AGENT=""
QUIT
+37 SET FILE=$PIECE($PIECE(Z,"^",3),"99VA",2)
+38 IF FILE'=50.6
IF FILE'=120.82
IF FILE'=50.605
IF FILE'=50.416
QUIT
+39 SET REMALLST=REMALLST_","_AGENT
+40 SET VALIST($$UP^XLFSTR(AGENT))=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+41 ;
+42 ;Removing the last comma
+43 SET VERALLST=$$SORT^PSOERUT(VERALLST)
+44 SET NOVALLST=$$SORT^PSOERUT(NOVALLST)
+45 SET VERARLST=$$SORT^PSOERUT(VERARLST)
+46 SET NOVARLST=$$SORT^PSOERUT(NOVARLST)
+47 SET REMALLST=$$SORT^PSOERUT(REMALLST)
+48 ;
+49 ;eRx Allergies
+50 SET ENKA=$$GET1^DIQ(52.49,ERXIEN,302,"I")
+51 ; Retrieving the list of eRx Patient Allergies (Sorted Alphabetically)
+52 DO ALRGDATA^PSOERXU9(.EALLDATA,ERXIEN,1)
+53 SET EALLLST=","
SET SEQ=0
FOR
SET SEQ=$ORDER(EALLDATA(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+54 IF $PIECE(EALLDATA(SEQ),"^",7)=""
QUIT
+55 SET EALLLST=EALLLST_$EXTRACT($PIECE(EALLDATA(SEQ),"^",7),1,38)_","
+56 SET ERXLIST($PIECE(EALLDATA(SEQ),"^",7))=""
End DoDot:1
+57 SET $EXTRACT(EALLLST)=""
+58 ;
+59 KILL ERXLINES,VALINES
+60 IF ENKA="Y"
Begin DoDot:1
+61 SET ERXLINES(1,0)="NO KNOWN ALLERGIES"
End DoDot:1
+62 IF EALLLST'=""
Begin DoDot:1
+63 SET X=$$C2S^PSOERUT(EALLLST)
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=39
SET DIWF="|"
DO ^DIWP
+64 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
+65 IF ENKA'="Y"
IF EALLLST=""
Begin DoDot:1
+66 SET ERXLINES(1,0)="NO ALLERGY INFORMATION RECEIVED"
End DoDot:1
+67 ;
+68 ; - VistA Allergies
+69 IF $GET(DFN)
Begin DoDot:1
+70 SET LN=0
KILL HDRLN
+71 IF VANOASS
SET LN=LN+1
SET VALINES(1,0)=" NO ALLERGY ASSESSMENT"
+72 IF VANKA
SET LN=LN+1
SET VALINES(1,0)=" NO KNOWN ALLERGIES"
+73 IF VERALLST'=""
Begin DoDot:2
+74 KILL ^UTILITY($JOB,"W")
+75 SET LN=LN+1
SET VALINES(LN,0)=" Verified:"
SET HDRLN(LN)=1
+76 SET X=$$C2S^PSOERUT(VERALLST)
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=38
SET DIWF="|"
DO ^DIWP
+77 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
+78 IF NOVALLST'=""
Begin DoDot:2
+79 KILL ^UTILITY($JOB,"W")
+80 SET LN=LN+1
SET VALINES(LN,0)=" Non-Verified:"
SET HDRLN(LN)=1
+81 SET X=$$C2S^PSOERUT(NOVALLST)
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=38
SET DIWF="|"
DO ^DIWP
+82 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
+83 IF REMALLST'=""
Begin DoDot:2
+84 KILL ^UTILITY($JOB,"W")
+85 SET LN=LN+1
SET VALINES(LN,0)="Remote Allergies:"
SET HDRLN(LN)=0
+86 SET X=$$C2S^PSOERUT(REMALLST)
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=38
SET DIWF="|"
DO ^DIWP
+87 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
+88 IF (VERARLST'="")!(NOVARLST'="")
Begin DoDot:2
+89 SET LN=LN+1
SET VALINES(LN,0)="Adverse Reactions:"
SET HDRLN(LN)=0
+90 IF VERARLST'=""
Begin DoDot:3
+91 SET LN=LN+1
SET VALINES(LN,0)=" Verified:"
SET HDRLN(LN)=1
+92 SET X=$$C2S^PSOERUT(VERARLST)
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=38
SET DIWF="|"
DO ^DIWP
+93 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
+94 IF NOVARLST'=""
Begin DoDot:3
+95 SET LN=LN+1
SET VALINES(LN,0)=" Non-Verified:"
SET HDRLN(LN)=1
+96 SET X=$$C2S^PSOERUT(NOVARLST)
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=38
SET DIWF="|"
DO ^DIWP
+97 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
+98 ;
+99 ; - Setting eRx Allergies & Local VistA Allergies (Sets reverse video for non-matching
+100 ; Allergies between eRx and VistA)
+101 SET XE="Allergy:"
SET XV="|Allergy:"
+102 DO ADDLINE^PSOERUT0(MODE,NMSPC,XE,XV)
+103 FOR ALLLN=1:1
if ('$DATA(ERXLINES(ALLLN))&'$DATA(VALINES(ALLLN)))
QUIT
Begin DoDot:1
+104 SET ERXALLS=$GET(ERXLINES(ALLLN,0))
SET VAALLS=$GET(VALINES(ALLLN,0))
+105 IF $DATA(VALIST)!$DATA(ERXLIST)
Begin DoDot:2
+106 FOR I=1:1:$LENGTH(ERXALLS,",")
Begin DoDot:3
+107 SET ERX1ALL=$PIECE(ERXALLS,",",I)
+108 IF ERX1ALL'=""
IF '$DATA(VALIST(ERX1ALL))
Begin DoDot:4
+109 SET REVLN(LINE,$FIND(ERXALLS,ERX1ALL)-$LENGTH(ERX1ALL)+1)=$LENGTH(ERX1ALL)
End DoDot:4
+110 IF '$TEST
SET HIGHLN(LINE,$FIND(ERXALLS,ERX1ALL)-$LENGTH(ERX1ALL)+1)=$LENGTH(ERX1ALL)
End DoDot:3
+111 IF '$DATA(HDRLN(ALLLN))
Begin DoDot:3
+112 FOR I=1:1:$LENGTH(VAALLS,",")
Begin DoDot:4
+113 SET VA1ALL=$PIECE(VAALLS,",",I)
if $EXTRACT(VA1ALL,1,2)=" "
SET $EXTRACT(VA1ALL,1,2)=""
+114 IF VA1ALL'=""
IF '$DATA(ERXLIST(VA1ALL))
Begin DoDot:5
+115 SET REVLN(LINE,40+$FIND(VAALLS,VA1ALL)-$LENGTH(VA1ALL))=$LENGTH(VA1ALL)
End DoDot:5
+116 IF '$TEST
SET HIGHLN(LINE,40+$FIND(VAALLS,VA1ALL)-$LENGTH(VA1ALL))=$LENGTH(VA1ALL)
End DoDot:4
End DoDot:3
+117 IF '$TEST
if $GET(HDRLN(ALLLN))
SET UNDERLN(LINE,42)=$LENGTH(VAALLS)-1
End DoDot:2
+118 IF '$TEST
Begin DoDot:2
+119 IF '$GET(DFN)!(ENKA="Y"&VANKA)
Begin DoDot:3
+120 SET HIGHLN(LINE,2)=$LENGTH(ERXALLS)
SET HIGHLN(LINE,42)=$LENGTH(VAALLS)
End DoDot:3
+121 IF '$TEST
SET REVLN(LINE,2)=$LENGTH(ERXALLS)
SET REVLN(LINE,42)=$LENGTH(VAALLS)
End DoDot:2
+122 SET XE=" "_$GET(ERXLINES(ALLLN,0))
+123 SET XV="|"_$GET(VALINES(ALLLN,0))
+124 DO ADDLINE^PSOERUT0(MODE,NMSPC,XE,XV)
End DoDot:1
+125 DO BLANKLN^PSOERUT0(MODE)
DO VIDEO^PSOERUT0()
+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,NPSPC,ERXIEN) ; Sets Diagnosis 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 NEW DIAGS,DIAG,DIAGZ,XE
+5 DO GETDIAGS(ERXIEN,.DIAGS)
+6 SET DIAG=0
FOR
SET DIAG=$ORDER(DIAGS(DIAG))
if 'DIAG
QUIT
Begin DoDot:1
+7 SET DIAGZ=DIAGS(DIAG)
+8 SET XE=$SELECT($PIECE(DIAGZ,"^")="P":"Primary",1:"Secondary")_" Dx:"
DO ADDLINE^PSOERUT0(MODE,NMSPC,XE,"|")
+9 SET XE=$PIECE(DIAGZ,"^",2)_" "_$PIECE(DIAGZ,"^",3)
+10 FOR
if $EXTRACT(XE,1,38)=""
QUIT
Begin DoDot:2
+11 SET HIGUNDLN(LINE,2)=$LENGTH($EXTRACT(XE,1,38))
+12 DO ADDLINE^PSOERUT0(MODE,NMSPC," "_$EXTRACT(XE,1,38),"|")
+13 SET XE=$EXTRACT(XE,39,9999)
End DoDot:2
+14 SET XE=$PIECE(DIAGZ,"^",4)
+15 FOR
if $EXTRACT(XE,1,38)=""
QUIT
Begin DoDot:2
+16 DO ADDLINE^PSOERUT0(MODE,NMSPC," "_$$COMPARE^PSOERUT0(MODE,$EXTRACT(XE,1,38),$EXTRACT(XE,1,38),2),"|")
+17 SET XE=$EXTRACT(XE,39,9999)
End DoDot:2
End DoDot:1
+18 IF $ORDER(DIAGS(0))
DO BLANKLN^PSOERUT0(MODE)
+19 QUIT
+20 ;
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
