Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOERUT3

PSOERUT3.m

Go to the documentation of this file.
  1. PSOERUT3 ;ALB/MFR - eRx Listman Allergy Utilities; 06/25/2022 5:14pm
  1. ;;7.0;OUTPATIENT PHARMACY;**700,746**;DEC 1997;Build 106
  1. ;
  1. ALLERGY(MODE,NPSPC,ERXIEN,DFN) ; Sets Allergy and Adverse Reaction information
  1. ; Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
  1. ; NMSPC - ListMan Temp Global Namespace (e.g., "PSOERXP1")
  1. ; ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
  1. ; DFN - Pointer to PATIENT File(#2)
  1. ;
  1. N IEN,X,XE,XV,LDAT,GMRAL,PSONOAL,LN,TYPE,VANOASS,VANKA,VERALLST,NOVALLST,REMALLST,VERARLST,NOVARLST,EALLDATA,ALLLN
  1. N VALIST,ERXLIST,VA1ALL,VAALLS,ERX1ALL,ERXALLS,I,HDRLN,EALLLST,ENKA
  1. Q:'$D(^PS(52.49,+$G(ERXIEN),0))
  1. S (VERALLST,NOVALLST,VERARLST,NOVARLST,REMALLST)="",(VANOASS,VANKA)=0
  1. I $G(DFN) D
  1. . ; Allergies & Adverse Reactions
  1. . S GMRA="0^0^111" D ^GMRADPT
  1. . I GMRAL="" S VANOASS=1 Q ; No Allergy Assessment
  1. . I GMRAL=0 S VANKA=1 Q ; No Known Allergies
  1. . I GMRAL D ; Allergies Found
  1. . . N ALL,Z,ALLLIST,VERIF,ALORAR,AGENT,FILE
  1. . . S ALL=0 F S ALL=$O(GMRAL(ALL)) Q:'ALL D
  1. . . . S Z=GMRAL(ALL),ALLLIST($S($P(Z,"^",4):"V",1:"NV"),$S('$P(Z,"^",5):"AL",1:"AR"),$P(Z,"^",2))=""
  1. . . S (VERIF,ALORAR,AGENT)=""
  1. . . F S VERIF=$O(ALLLIST(VERIF)) Q:VERIF="" D
  1. . . . F S ALORAR=$O(ALLLIST(VERIF,ALORAR)) Q:ALORAR="" D
  1. . . . . F S AGENT=$O(ALLLIST(VERIF,ALORAR,AGENT)) Q:AGENT="" D
  1. . . . . . I VERIF="V",ALORAR="AL" S VERALLST=VERALLST_","_AGENT
  1. . . . . . I VERIF="NV",ALORAR="AL" S NOVALLST=NOVALLST_","_AGENT
  1. . . . . . I VERIF="V",ALORAR="AR" S VERARLST=VERARLST_","_AGENT
  1. . . . . . I VERIF="NV",ALORAR="AR" S NOVARLST=NOVARLST_","_AGENT
  1. . . . . . S VALIST($$UP^XLFSTR(AGENT))=""
  1. . ; Remote Allergies
  1. . I $T(HAVEHDR^ORRDI1)'="" D
  1. . . I '$$HAVEHDR^ORRDI1 Q
  1. . . I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) Q
  1. . . I $T(GET^ORRDI1)]"" D GET^ORRDI1(DFN,"ART") D
  1. . . . I $P($G(^XTMP("ORRDI","ART",DFN,0)),"^",3)=0 Q
  1. . . . S ALL=0 F S ALL=$O(^XTMP("ORRDI","ART",DFN,ALL)) Q:'ALL D
  1. . . . . S Z=$G(^XTMP("ORRDI","ART",DFN,ALL,"GMRALLERGY",0))
  1. . . . . S AGENT=$P(Z,"^",2) Q:AGENT=""
  1. . . . . S FILE=$P($P(Z,"^",3),"99VA",2)
  1. . . . . I FILE'=50.6,FILE'=120.82,FILE'=50.605,FILE'=50.416 Q
  1. . . . . S REMALLST=REMALLST_","_AGENT
  1. . . . . S VALIST($$UP^XLFSTR(AGENT))=""
  1. ;
  1. ;Removing the last comma
  1. S VERALLST=$$SORT^PSOERUT(VERALLST)
  1. S NOVALLST=$$SORT^PSOERUT(NOVALLST)
  1. S VERARLST=$$SORT^PSOERUT(VERARLST)
  1. S NOVARLST=$$SORT^PSOERUT(NOVARLST)
  1. S REMALLST=$$SORT^PSOERUT(REMALLST)
  1. ;
  1. ;eRx Allergies
  1. S ENKA=$$GET1^DIQ(52.49,ERXIEN,302,"I")
  1. ; Retrieving the list of eRx Patient Allergies (Sorted Alphabetically)
  1. D ALRGDATA^PSOERXU9(.EALLDATA,ERXIEN,1)
  1. S EALLLST=",",SEQ=0 F S SEQ=$O(EALLDATA(SEQ)) Q:'SEQ D
  1. . I $P(EALLDATA(SEQ),"^",7)="" Q
  1. . S EALLLST=EALLLST_$E($P(EALLDATA(SEQ),"^",7),1,38)_","
  1. . S ERXLIST($P(EALLDATA(SEQ),"^",7))=""
  1. S $E(EALLLST)=""
  1. ;
  1. K ERXLINES,VALINES
  1. I ENKA="Y" D
  1. . S ERXLINES(1,0)="NO KNOWN ALLERGIES"
  1. I EALLLST'="" D
  1. . S X=$$C2S^PSOERUT(EALLLST) K ^UTILITY($J,"W") S DIWL=1,DIWR=39,DIWF="|" D ^DIWP
  1. . F I=1:1 Q:'$D(^UTILITY($J,"W",1,I)) S ERXLINES(I,0)=$$S2C^PSOERUT(^UTILITY($J,"W",1,I,0))
  1. I ENKA'="Y",EALLLST="" D
  1. . S ERXLINES(1,0)="NO ALLERGY INFORMATION RECEIVED"
  1. ;
  1. ; - VistA Allergies
  1. I $G(DFN) D
  1. . S LN=0 K HDRLN
  1. . I VANOASS S LN=LN+1,VALINES(1,0)=" NO ALLERGY ASSESSMENT"
  1. . I VANKA S LN=LN+1,VALINES(1,0)=" NO KNOWN ALLERGIES"
  1. . I VERALLST'="" D
  1. . . K ^UTILITY($J,"W")
  1. . . S LN=LN+1,VALINES(LN,0)=" Verified:",HDRLN(LN)=1
  1. . . S X=$$C2S^PSOERUT(VERALLST) K ^UTILITY($J,"W") S DIWL=1,DIWR=38,DIWF="|" D ^DIWP
  1. . . 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))
  1. . I NOVALLST'="" D
  1. . . K ^UTILITY($J,"W")
  1. . . S LN=LN+1,VALINES(LN,0)=" Non-Verified:",HDRLN(LN)=1
  1. . . S X=$$C2S^PSOERUT(NOVALLST) K ^UTILITY($J,"W") S DIWL=1,DIWR=38,DIWF="|" D ^DIWP
  1. . . 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))
  1. . I REMALLST'="" D
  1. . . K ^UTILITY($J,"W")
  1. . . S LN=LN+1,VALINES(LN,0)="Remote Allergies:",HDRLN(LN)=0
  1. . . S X=$$C2S^PSOERUT(REMALLST) K ^UTILITY($J,"W") S DIWL=1,DIWR=38,DIWF="|" D ^DIWP
  1. . . 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))
  1. . I (VERARLST'="")!(NOVARLST'="") D
  1. . . S LN=LN+1,VALINES(LN,0)="Adverse Reactions:",HDRLN(LN)=0
  1. . . I VERARLST'="" D
  1. . . . S LN=LN+1,VALINES(LN,0)=" Verified:",HDRLN(LN)=1
  1. . . . S X=$$C2S^PSOERUT(VERARLST) K ^UTILITY($J,"W") S DIWL=1,DIWR=38,DIWF="|" D ^DIWP
  1. . . . 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))
  1. . . I NOVARLST'="" D
  1. . . . S LN=LN+1,VALINES(LN,0)=" Non-Verified:",HDRLN(LN)=1
  1. . . . S X=$$C2S^PSOERUT(NOVARLST) K ^UTILITY($J,"W") S DIWL=1,DIWR=38,DIWF="|" D ^DIWP
  1. . . . 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))
  1. ;
  1. ; - Setting eRx Allergies & Local VistA Allergies (Sets reverse video for non-matching
  1. ; Allergies between eRx and VistA)
  1. S XE="Allergy:",XV="|Allergy:"
  1. D ADDLINE^PSOERUT0(MODE,NMSPC,XE,XV)
  1. F ALLLN=1:1 Q:('$D(ERXLINES(ALLLN))&'$D(VALINES(ALLLN))) D
  1. . S ERXALLS=$G(ERXLINES(ALLLN,0)),VAALLS=$G(VALINES(ALLLN,0))
  1. . I $D(VALIST)!$D(ERXLIST) D
  1. . . F I=1:1:$L(ERXALLS,",") D
  1. . . . S ERX1ALL=$P(ERXALLS,",",I)
  1. . . . I ERX1ALL'="",'$D(VALIST(ERX1ALL)) D
  1. . . . . S REVLN(LINE,$F(ERXALLS,ERX1ALL)-$L(ERX1ALL)+1)=$L(ERX1ALL)
  1. . . . E S HIGHLN(LINE,$F(ERXALLS,ERX1ALL)-$L(ERX1ALL)+1)=$L(ERX1ALL)
  1. . . I '$D(HDRLN(ALLLN)) D
  1. . . . F I=1:1:$L(VAALLS,",") D
  1. . . . . S VA1ALL=$P(VAALLS,",",I) S:$E(VA1ALL,1,2)=" " $E(VA1ALL,1,2)=""
  1. . . . . I VA1ALL'="",'$D(ERXLIST(VA1ALL)) D
  1. . . . . . S REVLN(LINE,40+$F(VAALLS,VA1ALL)-$L(VA1ALL))=$L(VA1ALL)
  1. . . . . E S HIGHLN(LINE,40+$F(VAALLS,VA1ALL)-$L(VA1ALL))=$L(VA1ALL)
  1. . . E S:$G(HDRLN(ALLLN)) UNDERLN(LINE,42)=$L(VAALLS)-1
  1. . E D
  1. . . I '$G(DFN)!(ENKA="Y"&VANKA) D
  1. . . . 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))
  1. . S XV="|"_$G(VALINES(ALLLN,0))
  1. . D ADDLINE^PSOERUT0(MODE,NMSPC,XE,XV)
  1. D BLANKLN^PSOERUT0(MODE),VIDEO^PSOERUT0()
  1. Q
  1. ;
  1. ADDALLS ; Add Alergies to the Screen (Reverses or Highlights Video for each Allergy)
  1. N ALLLN
  1. F ALLLN=1:1 Q:('$D(ERXLINES(ALLLN))&'$D(VALINES(ALLLN))) D
  1. . S ERXALLS=$G(ERXLINES(ALLLN,0)),VAALLS=$E($G(VALINES(ALLLN,0)),2,99)
  1. . I $D(VALIST)!$D(ERXLIST) D
  1. . . F I=1:1:$L(ERXALLS,",") D
  1. . . . S ERX1ALL=$P(ERXALLS,",",I)
  1. . . . I ERX1ALL'="",'$D(VALIST(ERX1ALL)) D
  1. . . . . S REVLN(LINE,$F(ERXALLS,ERX1ALL)-$L(ERX1ALL)+1)=$L(ERX1ALL)
  1. . . . E S HIGHLN(LINE,$F(ERXALLS,ERX1ALL)-$L(ERX1ALL)+1)=$L(ERX1ALL)
  1. . . I VAALLS'["erified:" D
  1. . . . F I=1:1:$L(VAALLS,",") D
  1. . . . . S VA1ALL=$P(VAALLS,",",I)
  1. . . . . I VA1ALL'="",'$D(ERXLIST(VA1ALL)) D
  1. . . . . . S REVLN(LINE,$F(VAALLS,VA1ALL)+42-$L(VA1ALL))=$L(VA1ALL)
  1. . . . . E S HIGHLN(LINE,$F(VAALLS,VA1ALL)+42-$L(VA1ALL))=$L(VA1ALL)
  1. . E D
  1. . . I '$G(DFN)!(ENKA="Y"&VANKA) D
  1. . . . S HIGHLN(LINE,2)=$L(ERXALLS),HIGHLN(LINE,42)=$L(VAALLS)+1
  1. . . E S REVLN(LINE,2)=$L(ERXALLS) S REVLN(LINE,42)=$L(VAALLS)+1
  1. . S XE=" "_$G(ERXLINES(ALLLN,0))
  1. . S XV="| "_$G(VALINES(ALLLN,0))
  1. . D ADDLINE^PSOERUT0(MODE,NMSPC,XE,XV)
  1. Q
  1. ;
  1. SETDIAGS(MODE,NPSPC,ERXIEN) ; Sets Diagnosis information
  1. ; Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
  1. ; NMSPC - ListMan Temp Global Namespace (e.g., "PSOERXP1")
  1. ; ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
  1. N DIAGS,DIAG,DIAGZ,XE
  1. D GETDIAGS(ERXIEN,.DIAGS)
  1. S DIAG=0 F S DIAG=$O(DIAGS(DIAG)) Q:'DIAG D
  1. . S DIAGZ=DIAGS(DIAG)
  1. . S XE=$S($P(DIAGZ,"^")="P":"Primary",1:"Secondary")_" Dx:" D ADDLINE^PSOERUT0(MODE,NMSPC,XE,"|")
  1. . S XE=$P(DIAGZ,"^",2)_" "_$P(DIAGZ,"^",3)
  1. . F Q:$E(XE,1,38)="" D
  1. . . S HIGUNDLN(LINE,2)=$L($E(XE,1,38))
  1. . . D ADDLINE^PSOERUT0(MODE,NMSPC," "_$E(XE,1,38),"|")
  1. . . S XE=$E(XE,39,9999)
  1. . S XE=$P(DIAGZ,"^",4)
  1. . F Q:$E(XE,1,38)="" D
  1. . . D ADDLINE^PSOERUT0(MODE,NMSPC," "_$$COMPARE^PSOERUT0(MODE,$E(XE,1,38),$E(XE,1,38),2),"|")
  1. . . S XE=$E(XE,39,9999)
  1. I $O(DIAGS(0)) D BLANKLN^PSOERUT0(MODE)
  1. Q
  1. ;
  1. GETDIAGS(ERXIEN,ICDARR) ; Returns the diagnosis codes for the eRx order
  1. ; Input: (r) ERXIEN - Pointer to the ERX HOLDING QUEUE file (52.49)
  1. ;Output: ICDARR array - P1: "P"rimary or "S"econdary diagnosis | P2: Diagnosis qualifier" "Diagnosis code
  1. ; P3: ICD Description | P4: Primary or Secondary Diagnosis description
  1. ;
  1. N MIEN,COUNT,DIAGIEN,DIENS,DIAGDAT,PDIAGQ,PDIAGV,PDESC,DRES,DRESL,DRESDAT
  1. N SDIAGQ,SDIAGV,SDESC,SDRES,SDRESL,SDRESDAT
  1. S (MIEN,COUNT)=0 F S MIEN=$O(^PS(52.49,ERXIEN,311,MIEN)) Q:'MIEN D
  1. . S DIAGIEN=0 F S DIAGIEN=$O(^PS(52.49,ERXIEN,311,MIEN,3,DIAGIEN)) Q:'DIAGIEN D
  1. . . S DIENS=DIAGIEN_","_MIEN_","_ERXIEN_"," N DIAGDAT
  1. . . D GETS^DIQ(52.493113,DIENS,"**","IE","DIAGDAT")
  1. . . S PDIAGQ=$G(DIAGDAT(52.493113,DIENS,1.2,"E"))
  1. . . S PDIAGV=$G(DIAGDAT(52.493113,DIENS,1.1,"E"))
  1. . . S PDESC=$G(DIAGDAT(52.493113,DIENS,2,"E"))
  1. . . I PDIAGQ["ICD" D
  1. . . . D ICDDESC^ICDXCODE(PDIAGQ,PDIAGV,,.DRES)
  1. . . . I '$O(DRES(0)) D Q
  1. . . . . S COUNT=COUNT+1,ICDARR(COUNT)="P^"_PDIAGQ_" "_PDIAGV_"^^"_PDESC
  1. . . . S DRESL=0 F S DRESL=$O(DRES(DRESL)) Q:'DRESL D
  1. . . . . S DRESDAT=$G(DRES(DRESL)) Q:DRESDAT=""
  1. . . . . S COUNT=COUNT+1,ICDARR(COUNT)="P^"_PDIAGQ_" "_PDIAGV_"^"_$$UP^XLFSTR(DRESDAT)_"^"_PDESC
  1. . . S SDIAGQ=$G(DIAGDAT(52.493113,DIENS,3.2,"E"))
  1. . . S SDIAGV=$G(DIAGDAT(52.493113,DIENS,3.1,"E"))
  1. . . S SDESC=$G(DIAGDAT(52.493113,DIENS,4,"E"))
  1. . . I SDIAGQ["ICD" D
  1. . . . D ICDDESC^ICDXCODE(SDIAGQ,SDIAGV,,.SDRES)
  1. . . . I '$O(SDRES(0)) D Q
  1. . . . . S COUNT=COUNT+1,ICDARR(COUNT)="S^"_SDIAGQ_" "_SDIAGV_"^^"_SDESC
  1. . . . S SDRESL=0 F S SDRESL=$O(SDRES(SDRESL)) Q:'SDRESL D
  1. . . . . S SDRESDAT=$G(SDRES(SDRESL)) Q:SDRESDAT=""
  1. . . . . S COUNT=COUNT+1
  1. . . . . S ICDARR(COUNT)="S^"_SDIAGQ_" "_SDIAGV_"^"_$$UP^XLFSTR(SDRESDAT)_"^"_SDESC
  1. Q
  1. ;
  1. SUGSIG(RXIEN,ERXIEN) ; Returns the Suggested SIG retrieved from the VA Rx
  1. ; Input:ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
  1. ; RXIEN - Prescription IEN - Pointer to PRESCRIPTION file (#52)
  1. ;Output:SUGSIG - Suggested SIG
  1. ;
  1. K SUGSIG,VADOSE,SIG,I,VAPATIEN,PSODRUG,VAPATINS
  1. I '$D(^PSRX(+$G(RXIEN),0))!'$D(^PS(52.49,+$G(ERXIEN),0)) Q ""
  1. S PSODRUG("IEN")=+$$GET1^DIQ(52,RXIEN,6,"I"),PSODRUG("OI")=+$$GET1^DIQ(50,PSODRUG("IEN"),2.1,"I")
  1. S SUGSIG=""
  1. D VARXDOSE^PSOERUT4(RXIEN,.VADOSE)
  1. K SIG D EN^PSOFSIG(.VADOSE)
  1. F I=1:1 Q:'$D(SIG(I)) S SUGSIG=SUGSIG_SIG(I)
  1. ; - Appending Patient Instrutions
  1. S VADRGIEN=+$$GET1^DIQ(52,RXIEN,6,"I")
  1. S VAOIIEN=+$$GET1^DIQ(50,VADRGIEN,2.1,"I")
  1. S VAPATIEN=+$$GET1^DIQ(52.49,ERXIEN,.05,"I")
  1. S VAPATINS=$$VAPATINS(VAOIIEN,VAPATIEN)
  1. I VAPATINS'="" S SUGSIG=SUGSIG_" "_VAPATINS
  1. Q SUGSIG
  1. ;
  1. VAPATINS(OI,DFN) ; Returns the Pharmacy Orderable Patient Instructions, if any
  1. ; Input: OI - Pointer to the PHARMACY ORDERABLE ITEM file (#50.7)
  1. ; (o)DFN - Pointer to the PATIEN file (#2)
  1. ;Output: VAPTINS - Expanded (if needed) OI Patient Instructions
  1. ;
  1. N VAPATINS,FLD,X,PSODIR,INS1
  1. S FLD=7
  1. I $G(DFN),$$GET1^DIQ(55,DFN,106,"I") S FLD=7.1
  1. S VAPATINS=$$GET1^DIQ(50.7,+$G(OI),FLD)
  1. ;
  1. I $G(VAPATINS)'="" D
  1. . S (X,PSODIR("INS"))=VAPATINS D SIG^PSOHELP S $E(INS1)="",VAPATINS=INS1
  1. Q VAPATINS