- 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 Jan 18, 2025@03:29:13 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