PSOERUT0 ;ALB/MFR - eRx Patient - ListMan Utilities; 06/03/2023 5:14pm
;;7.0;OUTPATIENT PHARMACY;**700,750,746,769,770**;DEC 1997;Build 145
;
SETPAT(MODE,ERXIEN,DFN,NMSPC,PENFLG,SDFLG) ; Set ListMan Side-By-Side Section for Patient
;Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
; ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
; DFN - Matched/Suggested VistA Patient - Pointer to PATIENT file (#2)
; (o)NMSPC - ListMan Temp Global Namespace (e.g., "PSOERXP1") - Required for LM Mode only
; (o)PENFLG - Pending Order Flag - 1: Pending Order Interface | 0: eRx Holding Queue Interface
; (o)SDFLG - Single eRx View/Display Flag - 1: Single eRx View/Display Interface | 0: eRx Holding Queue Interface
; Input Global Variable: LINE - Current ListMan Line # (Default)
; Output Global Variable: (ListMan Mode ONly)
; REVLN - Array Indicating Reverse Video for Line, position and size of the string
; HIGLN - Array Indicating Highlight for Line, position and size of the string
S:'$G(LINE) LINE=1 S NMSPC=$G(NMSPC)
N ERXPAT,X,XE,XV,DATA,ERXDM,ERR,ERXNAME,ERXDOB,ERXSEX,ERXSSN,ERXPHON1,ERXPHON2,ERXPHON3,ERXADDR,ERXCITY,ERXZIP
N ERXSTATE,ERXCNTRY,VADM,VAPA,VANAME,VADOB,VASEX,VASSN,VAPHONE1,VAPHONE2,VAADDR,VASTATE,VACNTRY,DIFFADDR,VAZIP
N ERXPHS,VAPHS,VACITY,ADDLN,DIWL,DIWR,DIWF
;
;eRx Patient Data
S ERXPAT=+$$GET1^DIQ(52.49,ERXIEN,.04,"I") I 'ERXPAT Q
D GETS^DIQ(52.46,ERXPAT_",",".01;.07;.08;1.4;1.6;3.1;3.2;3.3;3.4;3.5","EI","DATA","ERR") I '$D(DATA) Q
M ERXDM=DATA(52.46,ERXPAT_",")
S ERXNAME=$E(ERXDM(.01,"E"),1,33),ERXDOB=ERXDM(.08,"E"),ERXSEX=ERXDM(.07,"E")
S ERXSSN=ERXDM(1.4,"E"),ERXPHON1=$$ERXPHONE(ERXPAT,"HT"),ERXPHON2=$$ERXPHONE(ERXPAT,"CP")
S ERXPHON3=$$ERXPHONE(ERXPAT,"PT")
S ERXADDR=$$TRIM^XLFSTR(ERXDM(3.1,"E"))_$S($$TRIM^XLFSTR(ERXDM(3.2,"E"))'="":" "_ERXDM(3.2,"E"),1:"")
S ERXCITY=ERXDM(3.3,"E"),ERXSTATE=$$GET1^DIQ(5,+ERXDM(3.4,"I"),1)
S ERXZIP=ERXDM(3.5,"E"),ERXCNTRY=ERXDM(1.6,"E") S:ERXCNTRY="US" ERXCNTRY=""
;VistA Patient Data
I '$G(DFN) S DFN=+$$GET1^DIQ(52.49,ERXIEN,.05,"I")
S (VANAME,VADOB,VASSN,VASEX,VAADDR,VACITY,VASTATE,VAZIP,VACNTRY,VAPHONE1,VAPHONE2)=""
I $G(DFN) D
. D DEM^VADPT,ADD^VADPT
. S VANAME=$E($P(VADM(1),"^"),1,33),VADOB=$P(VADM(3),"^",2),VASEX=$P(VADM(5),"^",2),VASSN=$P(VADM(2),"^",2)
. S VAPHONE1=$P(VAPA(8),"^"),VAPHONE2=$$GET1^DIQ(2,DFN,.134,"E"),VACITY=$P(VAPA(4),"^")
. S VAZIP=$P(VAPA(11),"^"),VAADDR=$$TRIM^XLFSTR(VAPA(1))_$S($$TRIM^XLFSTR(VAPA(2))'="":" "_VAPA(2),1:"")
. S VAADDR=VAADDR_$S($$TRIM^XLFSTR(VAPA(3))'="":" "_VAPA(3),1:"")
. S VASTATE=$$GET1^DIQ(5,+VAPA(5),1),VACNTRY=$$GET1^DIQ(779.004,+$G(VAPA(25)),1.2)
. S VACNTRY=$S(VACNTRY="US":"",VACNTRY="CA":"CN",1:VACNTRY)
;
; - Patient Matching Header Line
I $G(PENFLG)!$G(SDFLG) D
. N AMATCH,VPATIEN,VALUSER,VALDTTM,MATCH,HDR
. S AMATCH=$$GET1^DIQ(52.49,ERXIEN,1.6,"I"),VPATIEN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
. S VALUSER=$$GET1^DIQ(52.49,ERXIEN,1.13,"E"),VALDTTM=$$GET1^DIQ(52.49,ERXIEN,1.14,"I")
. I $$GET1^DIQ(52.49,ERXIEN,.08,"I")="RE",'VALDTTM D
. . S MATCH="PREVIOUSLY MATCHED/VALIDATED (RENEWAL)"
. E D
. . S MATCH=$S(AMATCH=1:"AUTO-MATCHED",AMATCH=2:"AUTO-MATCHED/EDITED",VPATIEN:"MANUALLY-MATCHED",1:"")
. . I VALUSER'="",MATCH'="" S MATCH=MATCH_" | VALIDATED by "_$E(VALUSER,1,19)_" on "_$$FMTE^XLFDT(VALDTTM*10000\1/10000,"2Y")
. . I MATCH="" S MATCH="NOT MATCHED"
. S MATCH="PATIENT "_MATCH I $L(MATCH)>80 S MATCH=$E(MATCH,1,78)
. S HDR="",$E(HDR,(80-$L(MATCH))\2+1)=MATCH,$E(HDR,81)=""
. S $E(MATCH,81)=""
. S UNDERLN(LINE,1)=100 I HDR["/EDITED" S BLINKLN(LINE,$F(HDR,"/EDITED")-6)=6
. D ADDLINE(MODE,NMSPC,HDR,"")
;
S XE="Name: "_$$COMPARE(MODE,$E(ERXNAME,1,33),VANAME,7,,,'DFN)
S XV="|Name: "_$$COMPARE(MODE,VANAME,ERXNAME,47)
D ADDLINE(MODE,NMSPC,XE,XV)
I $L(ERXNAME)>33 D
. S XE=$$COMPARE(MODE,$E(ERXNAME,34,99),"",7,,,'DFN)
. D ADDLINE(MODE,NMSPC,XE)
S XE="DOB : "_$$COMPARE(MODE,ERXDOB,VADOB,7,,,'DFN)
S XV="|DOB : "_$$COMPARE(MODE,VADOB,ERXDOB,47)
D ADDLINE(MODE,NMSPC,XE,XV)
I $G(SDFLG) S LINE=LINE-1
S XE=$S('$G(SDFLG):"SSN : ",1:XE_" SSN : ")_$$COMPARE(MODE,ERXSSN,VASSN,$S('$G(SDFLG):7,1:28),,,'DFN)
S XV=$S('$G(SDFLG):"|SSN : ",1:XV_" SSN : ")_$$COMPARE(MODE,VASSN,ERXSSN,$S('$G(SDFLG):47,1:$S($L(VADOB)>10:70,1:69)))
D ADDLINE(MODE,NMSPC,XE,XV)
I '$G(SDFLG) D
. S XE="Sex : "_$$COMPARE(MODE,ERXSEX,VASEX,7,,,'DFN)
. S XV="|Sex : "_$$COMPARE(MODE,VASEX,ERXSEX,47)
. D ADDLINE(MODE,NMSPC,XE,XV) ;
; Pending Order Interface only shows Name,DOB, SSN and Sex
I $G(PENFLG) D Q
. D BLANKLN(MODE)
;
I '$G(SDFLG) D
. S XE="Address:",XV="|Address:" D ADDLINE(MODE,NMSPC,XE,XV)
. F ADDLN=1:1:5 D
. . I $$ADDRESS(ERXADDR,ADDLN)'=""!($$ADDRESS(VAADDR,ADDLN)'="") D
. . . S XE=" "_$$COMPARE(MODE,$$ADDRESS(ERXADDR,ADDLN),$$ADDRESS(VAADDR,ADDLN),2,"ADD",,'DFN)
. . . S XV="| "_$$COMPARE(MODE,$$ADDRESS(VAADDR,ADDLN),$$ADDRESS(ERXADDR,ADDLN),42,"ADD")
. . . D ADDLINE(MODE,NMSPC,XE,XV)
. S XE=" "_$$COMPARE(MODE,ERXCITY,VACITY,2,,,'DFN)
. S XE=XE_$S(ERXCITY'="":",",1:"")_$$COMPARE(MODE,ERXSTATE,VASTATE,$L(XE)+2,,,'DFN)
. S XE=XE_" "_$$COMPARE(MODE,ERXZIP,VAZIP,$L(XE)+3,"ZIP",,'DFN)
. S XV="| "_$$COMPARE(MODE,VACITY,ERXCITY,42)
. S XV=XV_$S(VACITY'="":",",1:"")_$$COMPARE(MODE,VASTATE,ERXSTATE,$L(XV)+41)
. S XV=XV_" "_$$COMPARE(MODE,VAZIP,ERXZIP,$L(XV)+42,"ZIP")
. D ADDLINE(MODE,NMSPC,XE,XV)
. I $G(ERXCNTRY)'=""!(VACNTRY'="") D
. . S XE=" "_$$COMPARE(MODE,ERXCNTRY,VACNTRY,2),XV="| "_$$COMPARE(MODE,VACNTRY,ERXCNTRY,42)
. . D ADDLINE(MODE,NMSPC,XE,XV)
;
S ERXPHS=$$CLNSTR(ERXPHON1)_","_$$CLNSTR(ERXPHON2)_","_$$CLNSTR(ERXPHON3)
S VAPHS=$$CLNSTR(VAPHONE1)_","_$$CLNSTR(VAPHONE2)
;
I $G(SDFLG) D Q ;display the patient phone,address,allergy and pharmacy narrative in the Single eRx View/Display mode
. D PTPHONE,PTADDRS
. D NARRATIV^PSOERUT6($G(DFN),NMSPC,MODE)
;
I ERXPHON3'="" D
. S XE="Primary Phone: "_$$COMPARE(MODE,ERXPHON3,$S(VAPHS[$$CLNSTR(ERXPHON3):ERXPHON3,1:""),16,,,'DFN),XV="|"
. D ADDLINE(MODE,NMSPC,XE,XV)
I ERXPHON1'=""!(VAPHONE1'="") D
. S XE="Home Phone: "_$$COMPARE(MODE,ERXPHON1,$S(VAPHS[$$CLNSTR(ERXPHON1):ERXPHON1,1:""),13,,,'DFN)
. S XV="|Home Phone: "_$$COMPARE(MODE,VAPHONE1,$S(ERXPHS[$$CLNSTR(VAPHONE1):VAPHONE1,1:""),53)
. D ADDLINE(MODE,NMSPC,XE,XV)
I ERXPHON2'=""!(VAPHONE2'="") D
. S XE="Cell Phone: "_$$COMPARE(MODE,ERXPHON2,$S(VAPHS[$$CLNSTR(ERXPHON2):ERXPHON2,1:""),13,,,'DFN)
. S XV="|Cell Phone: "_$$COMPARE(MODE,VAPHONE2,$S(ERXPHS[$$CLNSTR(VAPHONE2):VAPHONE2,1:""),53)
. D ADDLINE(MODE,NMSPC,XE,XV)
;
I MODE="LM" D
. I '$G(SDFLG) D
. . D BLANKLN(MODE)
. . S XV="|Pharmacy Narrative: " D ADDLINE(MODE,NMSPC,,XV)
. . I $G(DFN) D
. . . S X=$$GET1^DIQ(55,DFN,1,"E") K ^UTILITY($J,"W") S DIWL=1,DIWR=38,DIWF="|" D ^DIWP
. . . F I=1:1 Q:'$D(^UTILITY($J,"W",1,I)) D
. . . . S XV="| "_$$COMPARE(MODE,^UTILITY($J,"W",1,I,0),^UTILITY($J,"W",1,I,0),42) D ADDLINE(MODE,NMSPC,,XV)
. . D BLANKLN(MODE)
. . D ALLERGY^PSOERUT3(MODE,NMSPC,ERXIEN,$G(DFN))
. . D BLANKLN(MODE)
. . D WTHT(MODE,ERXIEN,DFN)
. . D BLANKLN(MODE)
. . D SETDIAGS^PSOERUT3(MODE,NMSPC,ERXIEN,"VP")
. . D BLANKLN(MODE)
E D BLANKLN(MODE)
Q
;
WTHT(MODE,ERXIEN,DFN) ; Adds eRx Weight & Height
; Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
; ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
; DFN - Pointer to PATIENT File(#2)
N ERXWT,ERXHT,VAWT,VAHT,X,XE,XV
S ERXWT=$$ERXWTHT(ERXIEN,"WT"),ERXHT=$$ERXWTHT(ERXIEN,"HT")
S VAWT=$$VAWTHT(DFN,"WT"),VAHT=$$VAWTHT(DFN,"HT")
;
S XE="Weight(kg): "_$$COMPARE(MODE,ERXWT,VAWT,13,,,'DFN)
S XV="|Weight(kg): "_$$COMPARE(MODE,VAWT,ERXWT,53,,,'DFN)
D ADDLINE(MODE,NMSPC,XE,XV)
S XE="Height(cm): "_$$COMPARE(MODE,ERXHT,VAHT,13,,,'DFN)
S XV="|Height(cm): "_$$COMPARE(MODE,VAHT,ERXHT,53,,,'DFN)
D ADDLINE(MODE,NMSPC,XE,XV)
Q
;
COMPARE(MODE,STR1,STR2,POS,TYPE,LMLINE,IGNNULL) ; Compare two strings and Sets Reverse/Highlight Video Array if different
; Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
; STR1 - String 1 to be compared with String 2
; STR2 - String 2 to be compared with String 1
; POS - Position to start the Reverse Video
; (o)TYPE - Zipcode field ("ADD": Address | "ZIP": Zip Code)
; (o)LMLINE - Current ListMan line (LM Mode only)
; (o)IGNNULL - Ignore when STR2 is null/blank
;Output: COMPARE - String to be displayed
N COMPARE,CLNSTR1,CLNSTR2 S COMPARE=STR1,TYPE=$G(TYPE)
I COMPARE="" Q ""
I TYPE="ADD" S STR1=$$CLNADD(STR1),STR2=$$CLNADD(STR2)
I TYPE="ZIP" S STR1=$E(STR1,1,5),STR2=$E(STR2,1,5)
S CLNSTR1=$$CLNSTR(STR1),CLNSTR2=$$CLNSTR(STR2)
I ('$G(IGNNULL)!(CLNSTR2'="")),CLNSTR1'=CLNSTR2,'$$EQDATES(STR1,STR2) D
. I (CLNSTR1'?.N),(CLNSTR2'?.N),CLNSTR1'="MALE",CLNSTR2'="MALE",CLNSTR1[CLNSTR2!(CLNSTR2[CLNSTR1) D
. . I MODE="RS" S COMPARE=$G(IOINHI)_COMPARE_$G(IOINORM)
. . I MODE="LM" S HIGHLN($S($G(LMLINE):LMLINE,1:LINE),POS)=$L(COMPARE)
. E D
. . I MODE="RS" S COMPARE=$G(IORVON)_COMPARE_$G(IORVOFF)
. . I MODE="LM" S REVLN($S($G(LMLINE):LMLINE,1:LINE),POS)=$L(COMPARE)
E D
. I MODE="RS" S COMPARE=$G(IOINHI)_COMPARE_$G(IOINORM)
. I MODE="LM" S HIGHLN($S($G(LMLINE):LMLINE,1:LINE),POS)=$L(COMPARE)
Q COMPARE
;
BLANKLN(MODE,NOVB) ; Add a Blank Line
;Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
; (o)NOVB - No Vertical Bar - 1: No Vertical Bar | 0/"" - Include Bar
N XE,XV
S XE="",$P(XE,"_",41)="",XV="",$P(XV,"_",$S($G(MODE)="LM":42,1:41))="" I '$G(NOVB) S $E(XV)="|"
D ADDLINE(MODE,NMSPC,XE,XV)
Q
;
ADDLINE(MODE,NMSPC,ETEXT,VTEXT) ;Adds a New Line to the list
;Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
; NMSPC - ListMan Temp Global Namespace (e.g., "PSOERXP1")
; ETEXT - eRx Text to be added
; VTEXT - VistA Text to be added
N TEXT S TEXT=""
I MODE="RS" D
. N Y S Y=$S($G(IOSL):IOSL,1:24)-3
. I '(LINE#Y) D
. . D PAUSE
. E W !
. W $G(ETEXT),?40,$G(VTEXT)
I MODE="LM" D
. S LINE=+$G(LINE)
. I $G(ETEXT)'="" S TEXT=$G(ETEXT)
. I $G(VTEXT)'="" S $E(TEXT,40)=$G(VTEXT)
. S ^TMP(NMSPC,$J,LINE,0)=TEXT
S LINE=LINE+1
Q
;
PAUSE ; Page break + erases the "Press Return..."
N DIR,I,XX S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR
F I=1:1:26 W $C(8)
S $P(XX," ",26)="" W XX
F I=1:1:26 W $C(8)
Q
;
EQDATES(DATE1,DATE2) ;Checks if the fields are valid dates and are the same
; Input: DATE1 - Date 1 to be compared with Date 2
; DATE2 - Date 2 to be compared with Date 1
;Output: 1 if DATE1 and DATE@ are equal | 0 if different
N X,Y,DT1,DT2
S X=DATE1 D ^%DT Q:(Y<1) 0 S DT1=Y
S X=DATE2 D ^%DT Q:(Y<1) 0 S DT2=Y
I DT1=DT2 Q 1
Q 0
;
CLNADD(ADD) ; Cleans an Address String
; Input: ADD - Address Line string to be cleaned
;Output: Cleaned Address Line string
N REPS,REP,FIND,LIST,SYN,I,J
S ADD=" "_$$UP^XLFSTR(ADD)_" "
F I=1:1 S LIST=$T(USPSABBS+I^PSOERUT1) Q:(LIST'[";") D
. F J=3:1 Q:($P(LIST,";",J)="") S SYN=$P(LIST,";",J),REPS($P(SYN,"^",1))=$P(SYN,"^",2)
S REP="" F S REP=$O(REPS(REP)) Q:REP="" D
. S FIND=$F(ADD,REP) I FIND S ADD=$E(ADD,1,FIND-$L(REP)-1)_REPS(REP)_$E(ADD,FIND,9999)
S $E(ADD,$L(ADD))=""
Q ADD
;
CLNSTR(STR) ; Cleans String (Removes any characters different than a-A & 1-9)
; Input: STR - String to be cleaned
;Output: Cleaned string
N CHR,CLNSTR,I S CLNSTR=""
S STR=$$UP^XLFSTR(STR) I STR?.P Q STR
F I=1:1:$L(STR) S CHR=$E(STR,I) I (CHR?1N)!(($A(CHR)>64)&($A(CHR)<91)) S CLNSTR=CLNSTR_CHR
Q CLNSTR
;
RESET() ; Reset Video Atributes
; - Resetting list to NORMAL video attributes
N I
I $D(VALMEVL) F I=1:1:$G(LASTLINE) D RESTORE^VALM10(I)
K REVLN,HIGHLN,UNDERLN,BLINKLN,HIGUNDLN
Q
;
VIDEO() ; Changes the Video Attributes for the list
N I,LN,POS
;
I '$D(IORVOFF)!'$D(VALMEVL) Q
F I=0:1:$G(LINE) D CNTRL^VALM10(I,1,80,IORVOFF_IOINORM,IORVOFF_IOINORM)
S LN=0 F S LN=$O(REVLN(LN)) Q:'LN D
. S POS=0 F S POS=$O(REVLN(LN,POS)) Q:'POS D
. . D CNTRL^VALM10(LN,POS,REVLN(LN,POS),IORVON,IORVOFF_IOINORM)
S LN=0 F S LN=$O(HIGHLN(LN)) Q:'LN D
. S POS=0 F S POS=$O(HIGHLN(LN,POS)) Q:'POS D
. . D CNTRL^VALM10(LN,POS,HIGHLN(LN,POS),IOINHI,IOINORM)
S LN=0 F S LN=$O(UNDERLN(LN)) Q:'LN D
. S POS=0 F S POS=$O(UNDERLN(LN,POS)) Q:'POS D
. . D CNTRL^VALM10(LN,POS,UNDERLN(LN,POS),IOUON,IOUOFF)
S LN=0 F S LN=$O(BLINKLN(LN)) Q:'LN D
. S POS=0 F S POS=$O(BLINKLN(LN,POS)) Q:'POS D
. . D CNTRL^VALM10(LN,POS,BLINKLN(LN,POS),IOBON,IOBOFF)
S LN=0 F S LN=$O(HIGUNDLN(LN)) Q:'LN D
. S POS=0 F S POS=$O(HIGUNDLN(LN,POS)) Q:'POS D
. . D CNTRL^VALM10(LN,POS,HIGUNDLN(LN,POS),IOINHI_IOUON,IOUOFF_IOINORM)
Q
;
ERXPHONE(ERXPAT,TYPE) ; Return the eRx Patient Phone # (if there is one)
; Input: ERXPAT - Pointer to ERX PATIENT (#52.46)
; TYPE - "PT": Primary Telephone | "HT": Home Telephone
;
N ERXPHONE,COMM,Z S ERXPHONE=""
S COMM=0 F S COMM=$O(^PS(52.46,ERXPAT,13,COMM)) Q:'COMM D I ERXPHONE'="" Q
. S Z=$G(^PS(52.46,ERXPAT,13,COMM,0))
. I $P(Z,"^",2)=TYPE S ERXPHONE=$P(Z,"^",3)
Q ERXPHONE
;
ADDRESS(VALUE,ADDLINE) ; Returns Address Line1, Line2, Line3... (max 39 characters)
; Input: VALUE - Complete Address (Line1+Line2+Line3)
; ADDLINE - Line of the formatted address
;Output: ADDRESS - Returns the Line # Address Text for 39-char fields
N ADDRESS,DIWL,DIWR,X,I
K ^UTILITY($J,"W") S X=$$TRIM^XLFSTR(VALUE),DIWL=1,DIWR=39 D ^DIWP
S ADDRESS=$$TRIM^XLFSTR($G(^UTILITY($J,"W",1,ADDLINE,0)))
K ^UTILITY($J,"W")
Q ADDRESS
;
ERXWTHT(ERXIEN,TYPE) ; eRx Patient Weight/Height
; Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
; TYPE - "WT": Weight in Kg | "HT": Height in cm
;Output: Value or ""
N ERXWTHT,OBS,IENS,LCODE,LDATA,HUOM,WUOM,HOBDT,WOBDT,RET,IEN
S IEN=0,ERXWTHT=""
F S IEN=$O(^PS(52.49,ERXIEN,306,IEN)) Q:'IEN D
. S IENS=IEN_","_ERXIEN_","
. S LCODE=$$GET1^DIQ(52.49306,IENS,1,"E")
. Q:'LCODE
. D CSDATA^ETSLNC(LCODE,"LNC",DT,.LDATA)
. I TYPE="HT",$G(LDATA("LEX",1))["BODY HEIGHT" D
. . S ERXWTHT=$$GET1^DIQ(52.49306,IENS,3,"E")
. . S HUOM=$$UP^XLFSTR($$GET1^DIQ(52.49306,IENS,4,"E"))
. . S HOBDT=$P($$GET1^DIQ(52.49306,IENS,6,"I"),"."),HOBDT=$$FMTE^XLFDT(HOBDT,"5Z")
. . I HUOM["IN" S ERXWTHT=ERXWTHT*2.54,$P(ERXWTHT,".",2)=$E($P(ERXWTHT,".",2),1,2)
. I TYPE="WT",$G(LDATA("LEX",1))["BODY WEIGHT" D
. . S ERXWTHT=$$GET1^DIQ(52.49306,IENS,3,"E")
. . S WOBDT=$P($$GET1^DIQ(52.49306,IENS,6,"I"),"."),WOBDT=$$FMTE^XLFDT(WOBDT,"5Z")
. . S WUOM=$$UP^XLFSTR($$GET1^DIQ(52.49306,IENS,4,"E"))
. . I WUOM["LB" S ERXWTHT=ERXWTHT/2.2046,$P(ERXWTHT,".",2)=$E($P(ERXWTHT,".",2),1,2)
. . I WUOM="G" S ERXWTHT=ERXWTHT/1000,$P(ERXWTHT,".",2)=$E($P(ERXWTHT,".",2),1,2)
Q ERXWTHT
;
VAWTHT(DFN,TYPE) ; VistA Patient Weight/Height
; Input: DFN - Pointer to PATIENT File(#2)
; TYPE - "WT": Weight in Kg | "HT": Height in cm
;Output: Value or ""
N WT,HT,X,Y,GMRVSTR,VM
I '$G(DFN) Q ""
S (WT,HT)="",X="GMRVUTL" X ^%ZOSF("TEST") I $T D
. F GMRVSTR="WT","HT" S VM=GMRVSTR D EN6^GMRVUTL S @VM=X,$P(@VM,"^")=$E($P(@VM,"^"),4,5)_"/"_$E($P(@VM,"^"),6,7)_"/"_($E($P(@VM,"^"),1,3)+1700)
. S X=$P(WT,"^",8),Y=$J(X/2.2046226,0,2),$P(WT,"^",9)=Y,X=$P(HT,"^",8),Y=$J(2.54*X,0,2),$P(HT,"^",9)=Y
;
I TYPE="WT",$P(WT,"^",8) Q $P(WT,"^",9)
I TYPE="HT",$P(HT,"^",8) Q $P(HT,"^",9)
Q ""
PTPHONE ;display phone in the Single eRx View/Display mode
N EPTPHONE,VPTPHONE
S EPTPHONE=$S(VAPHS[$$CLNSTR(ERXPHON3)&(ERXPHON3'=""):ERXPHON3,VAPHS[$$CLNSTR(ERXPHON1)&(ERXPHON1'=""):ERXPHON1,VAPHS[$$CLNSTR(ERXPHON2)&(ERXPHON2'=""):ERXPHON2,1:$S(ERXPHON2'="":ERXPHON2,ERXPHON1'="":ERXPHON1,1:ERXPHON3))
S VPTPHONE=$S(ERXPHS[$$CLNSTR(VAPHONE2)&(VAPHONE2'=""):VAPHONE2,ERXPHS[$$CLNSTR(VAPHONE1)&(VAPHONE1'=""):VAPHONE1,1:$S(VAPHONE2'="":VAPHONE2,1:VAPHONE1))
S XE="Phone: "_$$COMPARE(MODE,EPTPHONE,VPTPHONE,8,,,'DFN)
S XV="|Phone: "_$$COMPARE(MODE,VPTPHONE,EPTPHONE,48)
D ADDLINE(MODE,NMSPC,XE,XV)
Q
;
PTADDRS ;display the patient address in the Single eRx View/Display mode
Q:($G(ERXADDR)="")&($G(VAADDR)="")
N XE,XV,EFULLADD,VFULLADD S (XE,XV,VFULLADD)=""
S:$G(ERXADDR)'="" XE=ERXADDR
S XE=XE_" "_ERXCITY
S XE=XE_$S(ERXCITY'="":",",1:"")_ERXSTATE
I $G(ERXCNTRY)'="" S XE=XE_" "_ERXCNTRY
S EFULLADD=$$CLNSTR($$CLNADD(XE_$E(ERXZIP,1,5)))
I $L(XE_" "_$E(ERXZIP,1,5))>38 S XE=$E(XE,1,30)_"..."_$E(ERXZIP,1,5)
E S XE=XE_" "_$E(ERXZIP,1,5)
I $G(DFN) D
. S XV=VAADDR
. S XV=XV_" "_VACITY
. S XV=XV_$S(VACITY'="":",",1:"")_VASTATE
. I $G(VACNTRY)'="" S XV=XV_" "_VACNTRY
. S VFULLADD=$$CLNSTR($$CLNADD(XV_$E(VAZIP,1,5)))
. I $L(XV_" "_$E(VAZIP,1,5))>38 S XV=$E(XV,1,30)_"..."_$E(VAZIP,1,5)
. E S XV=XV_" "_$E(VAZIP,1,5)
I XE'="" S XE=" "_$$COMPARE(MODE,XE,$S(EFULLADD=VFULLADD:XE,1:XV),2,"ADD",,'DFN)
I XV'="" S XV="| "_$$COMPARE(MODE,XV,$S(EFULLADD=VFULLADD:XV,1:XE),42,"ADD")
D ADDLINE(MODE,NMSPC,XE,XV)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERUT0 17175 printed Sep 23, 2025@20:04:25 Page 2
PSOERUT0 ;ALB/MFR - eRx Patient - ListMan Utilities; 06/03/2023 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**700,750,746,769,770**;DEC 1997;Build 145
+2 ;
SETPAT(MODE,ERXIEN,DFN,NMSPC,PENFLG,SDFLG) ; Set ListMan Side-By-Side Section for Patient
+1 ;Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
+2 ; ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+3 ; DFN - Matched/Suggested VistA Patient - Pointer to PATIENT file (#2)
+4 ; (o)NMSPC - ListMan Temp Global Namespace (e.g., "PSOERXP1") - Required for LM Mode only
+5 ; (o)PENFLG - Pending Order Flag - 1: Pending Order Interface | 0: eRx Holding Queue Interface
+6 ; (o)SDFLG - Single eRx View/Display Flag - 1: Single eRx View/Display Interface | 0: eRx Holding Queue Interface
+7 ; Input Global Variable: LINE - Current ListMan Line # (Default)
+8 ; Output Global Variable: (ListMan Mode ONly)
+9 ; REVLN - Array Indicating Reverse Video for Line, position and size of the string
+10 ; HIGLN - Array Indicating Highlight for Line, position and size of the string
+11 if '$GET(LINE)
SET LINE=1
SET NMSPC=$GET(NMSPC)
+12 NEW ERXPAT,X,XE,XV,DATA,ERXDM,ERR,ERXNAME,ERXDOB,ERXSEX,ERXSSN,ERXPHON1,ERXPHON2,ERXPHON3,ERXADDR,ERXCITY,ERXZIP
+13 NEW ERXSTATE,ERXCNTRY,VADM,VAPA,VANAME,VADOB,VASEX,VASSN,VAPHONE1,VAPHONE2,VAADDR,VASTATE,VACNTRY,DIFFADDR,VAZIP
+14 NEW ERXPHS,VAPHS,VACITY,ADDLN,DIWL,DIWR,DIWF
+15 ;
+16 ;eRx Patient Data
+17 SET ERXPAT=+$$GET1^DIQ(52.49,ERXIEN,.04,"I")
IF 'ERXPAT
QUIT
+18 DO GETS^DIQ(52.46,ERXPAT_",",".01;.07;.08;1.4;1.6;3.1;3.2;3.3;3.4;3.5","EI","DATA","ERR")
IF '$DATA(DATA)
QUIT
+19 MERGE ERXDM=DATA(52.46,ERXPAT_",")
+20 SET ERXNAME=$EXTRACT(ERXDM(.01,"E"),1,33)
SET ERXDOB=ERXDM(.08,"E")
SET ERXSEX=ERXDM(.07,"E")
+21 SET ERXSSN=ERXDM(1.4,"E")
SET ERXPHON1=$$ERXPHONE(ERXPAT,"HT")
SET ERXPHON2=$$ERXPHONE(ERXPAT,"CP")
+22 SET ERXPHON3=$$ERXPHONE(ERXPAT,"PT")
+23 SET ERXADDR=$$TRIM^XLFSTR(ERXDM(3.1,"E"))_$SELECT($$TRIM^XLFSTR(ERXDM(3.2,"E"))'="":" "_ERXDM(3.2,"E"),1:"")
+24 SET ERXCITY=ERXDM(3.3,"E")
SET ERXSTATE=$$GET1^DIQ(5,+ERXDM(3.4,"I"),1)
+25 SET ERXZIP=ERXDM(3.5,"E")
SET ERXCNTRY=ERXDM(1.6,"E")
if ERXCNTRY="US"
SET ERXCNTRY=""
+26 ;VistA Patient Data
+27 IF '$GET(DFN)
SET DFN=+$$GET1^DIQ(52.49,ERXIEN,.05,"I")
+28 SET (VANAME,VADOB,VASSN,VASEX,VAADDR,VACITY,VASTATE,VAZIP,VACNTRY,VAPHONE1,VAPHONE2)=""
+29 IF $GET(DFN)
Begin DoDot:1
+30 DO DEM^VADPT
DO ADD^VADPT
+31 SET VANAME=$EXTRACT($PIECE(VADM(1),"^"),1,33)
SET VADOB=$PIECE(VADM(3),"^",2)
SET VASEX=$PIECE(VADM(5),"^",2)
SET VASSN=$PIECE(VADM(2),"^",2)
+32 SET VAPHONE1=$PIECE(VAPA(8),"^")
SET VAPHONE2=$$GET1^DIQ(2,DFN,.134,"E")
SET VACITY=$PIECE(VAPA(4),"^")
+33 SET VAZIP=$PIECE(VAPA(11),"^")
SET VAADDR=$$TRIM^XLFSTR(VAPA(1))_$SELECT($$TRIM^XLFSTR(VAPA(2))'="":" "_VAPA(2),1:"")
+34 SET VAADDR=VAADDR_$SELECT($$TRIM^XLFSTR(VAPA(3))'="":" "_VAPA(3),1:"")
+35 SET VASTATE=$$GET1^DIQ(5,+VAPA(5),1)
SET VACNTRY=$$GET1^DIQ(779.004,+$GET(VAPA(25)),1.2)
+36 SET VACNTRY=$SELECT(VACNTRY="US":"",VACNTRY="CA":"CN",1:VACNTRY)
End DoDot:1
+37 ;
+38 ; - Patient Matching Header Line
+39 IF $GET(PENFLG)!$GET(SDFLG)
Begin DoDot:1
+40 NEW AMATCH,VPATIEN,VALUSER,VALDTTM,MATCH,HDR
+41 SET AMATCH=$$GET1^DIQ(52.49,ERXIEN,1.6,"I")
SET VPATIEN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
+42 SET VALUSER=$$GET1^DIQ(52.49,ERXIEN,1.13,"E")
SET VALDTTM=$$GET1^DIQ(52.49,ERXIEN,1.14,"I")
+43 IF $$GET1^DIQ(52.49,ERXIEN,.08,"I")="RE"
IF 'VALDTTM
Begin DoDot:2
+44 SET MATCH="PREVIOUSLY MATCHED/VALIDATED (RENEWAL)"
End DoDot:2
+45 IF '$TEST
Begin DoDot:2
+46 SET MATCH=$SELECT(AMATCH=1:"AUTO-MATCHED",AMATCH=2:"AUTO-MATCHED/EDITED",VPATIEN:"MANUALLY-MATCHED",1:"")
+47 IF VALUSER'=""
IF MATCH'=""
SET MATCH=MATCH_" | VALIDATED by "_$EXTRACT(VALUSER,1,19)_" on "_$$FMTE^XLFDT(VALDTTM*10000\1/10000,"2Y")
+48 IF MATCH=""
SET MATCH="NOT MATCHED"
End DoDot:2
+49 SET MATCH="PATIENT "_MATCH
IF $LENGTH(MATCH)>80
SET MATCH=$EXTRACT(MATCH,1,78)
+50 SET HDR=""
SET $EXTRACT(HDR,(80-$LENGTH(MATCH))\2+1)=MATCH
SET $EXTRACT(HDR,81)=""
+51 SET $EXTRACT(MATCH,81)=""
+52 SET UNDERLN(LINE,1)=100
IF HDR["/EDITED"
SET BLINKLN(LINE,$FIND(HDR,"/EDITED")-6)=6
+53 DO ADDLINE(MODE,NMSPC,HDR,"")
End DoDot:1
+54 ;
+55 SET XE="Name: "_$$COMPARE(MODE,$EXTRACT(ERXNAME,1,33),VANAME,7,,,'DFN)
+56 SET XV="|Name: "_$$COMPARE(MODE,VANAME,ERXNAME,47)
+57 DO ADDLINE(MODE,NMSPC,XE,XV)
+58 IF $LENGTH(ERXNAME)>33
Begin DoDot:1
+59 SET XE=$$COMPARE(MODE,$EXTRACT(ERXNAME,34,99),"",7,,,'DFN)
+60 DO ADDLINE(MODE,NMSPC,XE)
End DoDot:1
+61 SET XE="DOB : "_$$COMPARE(MODE,ERXDOB,VADOB,7,,,'DFN)
+62 SET XV="|DOB : "_$$COMPARE(MODE,VADOB,ERXDOB,47)
+63 DO ADDLINE(MODE,NMSPC,XE,XV)
+64 IF $GET(SDFLG)
SET LINE=LINE-1
+65 SET XE=$SELECT('$GET(SDFLG):"SSN : ",1:XE_" SSN : ")_$$COMPARE(MODE,ERXSSN,VASSN,$SELECT('$GET(SDFLG):7,1:28),,,'DFN)
+66 SET XV=$SELECT('$GET(SDFLG):"|SSN : ",1:XV_" SSN : ")_$$COMPARE(MODE,VASSN,ERXSSN,$SELECT('$GET(SDFLG):47,1:$SELECT($LENGTH(VADOB)>10:70,1:69)))
+67 DO ADDLINE(MODE,NMSPC,XE,XV)
+68 IF '$GET(SDFLG)
Begin DoDot:1
+69 SET XE="Sex : "_$$COMPARE(MODE,ERXSEX,VASEX,7,,,'DFN)
+70 SET XV="|Sex : "_$$COMPARE(MODE,VASEX,ERXSEX,47)
+71 ;
DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:1
+72 ; Pending Order Interface only shows Name,DOB, SSN and Sex
+73 IF $GET(PENFLG)
Begin DoDot:1
+74 DO BLANKLN(MODE)
End DoDot:1
QUIT
+75 ;
+76 IF '$GET(SDFLG)
Begin DoDot:1
+77 SET XE="Address:"
SET XV="|Address:"
DO ADDLINE(MODE,NMSPC,XE,XV)
+78 FOR ADDLN=1:1:5
Begin DoDot:2
+79 IF $$ADDRESS(ERXADDR,ADDLN)'=""!($$ADDRESS(VAADDR,ADDLN)'="")
Begin DoDot:3
+80 SET XE=" "_$$COMPARE(MODE,$$ADDRESS(ERXADDR,ADDLN),$$ADDRESS(VAADDR,ADDLN),2,"ADD",,'DFN)
+81 SET XV="| "_$$COMPARE(MODE,$$ADDRESS(VAADDR,ADDLN),$$ADDRESS(ERXADDR,ADDLN),42,"ADD")
+82 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:3
End DoDot:2
+83 SET XE=" "_$$COMPARE(MODE,ERXCITY,VACITY,2,,,'DFN)
+84 SET XE=XE_$SELECT(ERXCITY'="":",",1:"")_$$COMPARE(MODE,ERXSTATE,VASTATE,$LENGTH(XE)+2,,,'DFN)
+85 SET XE=XE_" "_$$COMPARE(MODE,ERXZIP,VAZIP,$LENGTH(XE)+3,"ZIP",,'DFN)
+86 SET XV="| "_$$COMPARE(MODE,VACITY,ERXCITY,42)
+87 SET XV=XV_$SELECT(VACITY'="":",",1:"")_$$COMPARE(MODE,VASTATE,ERXSTATE,$LENGTH(XV)+41)
+88 SET XV=XV_" "_$$COMPARE(MODE,VAZIP,ERXZIP,$LENGTH(XV)+42,"ZIP")
+89 DO ADDLINE(MODE,NMSPC,XE,XV)
+90 IF $GET(ERXCNTRY)'=""!(VACNTRY'="")
Begin DoDot:2
+91 SET XE=" "_$$COMPARE(MODE,ERXCNTRY,VACNTRY,2)
SET XV="| "_$$COMPARE(MODE,VACNTRY,ERXCNTRY,42)
+92 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:2
End DoDot:1
+93 ;
+94 SET ERXPHS=$$CLNSTR(ERXPHON1)_","_$$CLNSTR(ERXPHON2)_","_$$CLNSTR(ERXPHON3)
+95 SET VAPHS=$$CLNSTR(VAPHONE1)_","_$$CLNSTR(VAPHONE2)
+96 ;
+97 ;display the patient phone,address,allergy and pharmacy narrative in the Single eRx View/Display mode
IF $GET(SDFLG)
Begin DoDot:1
+98 DO PTPHONE
DO PTADDRS
+99 DO NARRATIV^PSOERUT6($GET(DFN),NMSPC,MODE)
End DoDot:1
QUIT
+100 ;
+101 IF ERXPHON3'=""
Begin DoDot:1
+102 SET XE="Primary Phone: "_$$COMPARE(MODE,ERXPHON3,$SELECT(VAPHS[$$CLNSTR(ERXPHON3):ERXPHON3,1:""),16,,,'DFN)
SET XV="|"
+103 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:1
+104 IF ERXPHON1'=""!(VAPHONE1'="")
Begin DoDot:1
+105 SET XE="Home Phone: "_$$COMPARE(MODE,ERXPHON1,$SELECT(VAPHS[$$CLNSTR(ERXPHON1):ERXPHON1,1:""),13,,,'DFN)
+106 SET XV="|Home Phone: "_$$COMPARE(MODE,VAPHONE1,$SELECT(ERXPHS[$$CLNSTR(VAPHONE1):VAPHONE1,1:""),53)
+107 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:1
+108 IF ERXPHON2'=""!(VAPHONE2'="")
Begin DoDot:1
+109 SET XE="Cell Phone: "_$$COMPARE(MODE,ERXPHON2,$SELECT(VAPHS[$$CLNSTR(ERXPHON2):ERXPHON2,1:""),13,,,'DFN)
+110 SET XV="|Cell Phone: "_$$COMPARE(MODE,VAPHONE2,$SELECT(ERXPHS[$$CLNSTR(VAPHONE2):VAPHONE2,1:""),53)
+111 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:1
+112 ;
+113 IF MODE="LM"
Begin DoDot:1
+114 IF '$GET(SDFLG)
Begin DoDot:2
+115 DO BLANKLN(MODE)
+116 SET XV="|Pharmacy Narrative: "
DO ADDLINE(MODE,NMSPC,,XV)
+117 IF $GET(DFN)
Begin DoDot:3
+118 SET X=$$GET1^DIQ(55,DFN,1,"E")
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=38
SET DIWF="|"
DO ^DIWP
+119 FOR I=1:1
if '$DATA(^UTILITY($JOB,"W",1,I))
QUIT
Begin DoDot:4
+120 SET XV="| "_$$COMPARE(MODE,^UTILITY($JOB,"W",1,I,0),^UTILITY($JOB,"W",1,I,0),42)
DO ADDLINE(MODE,NMSPC,,XV)
End DoDot:4
End DoDot:3
+121 DO BLANKLN(MODE)
+122 DO ALLERGY^PSOERUT3(MODE,NMSPC,ERXIEN,$GET(DFN))
+123 DO BLANKLN(MODE)
+124 DO WTHT(MODE,ERXIEN,DFN)
+125 DO BLANKLN(MODE)
+126 DO SETDIAGS^PSOERUT3(MODE,NMSPC,ERXIEN,"VP")
+127 DO BLANKLN(MODE)
End DoDot:2
End DoDot:1
+128 IF '$TEST
DO BLANKLN(MODE)
+129 QUIT
+130 ;
WTHT(MODE,ERXIEN,DFN) ; Adds eRx Weight & Height
+1 ; Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
+2 ; ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+3 ; DFN - Pointer to PATIENT File(#2)
+4 NEW ERXWT,ERXHT,VAWT,VAHT,X,XE,XV
+5 SET ERXWT=$$ERXWTHT(ERXIEN,"WT")
SET ERXHT=$$ERXWTHT(ERXIEN,"HT")
+6 SET VAWT=$$VAWTHT(DFN,"WT")
SET VAHT=$$VAWTHT(DFN,"HT")
+7 ;
+8 SET XE="Weight(kg): "_$$COMPARE(MODE,ERXWT,VAWT,13,,,'DFN)
+9 SET XV="|Weight(kg): "_$$COMPARE(MODE,VAWT,ERXWT,53,,,'DFN)
+10 DO ADDLINE(MODE,NMSPC,XE,XV)
+11 SET XE="Height(cm): "_$$COMPARE(MODE,ERXHT,VAHT,13,,,'DFN)
+12 SET XV="|Height(cm): "_$$COMPARE(MODE,VAHT,ERXHT,53,,,'DFN)
+13 DO ADDLINE(MODE,NMSPC,XE,XV)
+14 QUIT
+15 ;
COMPARE(MODE,STR1,STR2,POS,TYPE,LMLINE,IGNNULL) ; Compare two strings and Sets Reverse/Highlight Video Array if different
+1 ; Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
+2 ; STR1 - String 1 to be compared with String 2
+3 ; STR2 - String 2 to be compared with String 1
+4 ; POS - Position to start the Reverse Video
+5 ; (o)TYPE - Zipcode field ("ADD": Address | "ZIP": Zip Code)
+6 ; (o)LMLINE - Current ListMan line (LM Mode only)
+7 ; (o)IGNNULL - Ignore when STR2 is null/blank
+8 ;Output: COMPARE - String to be displayed
+9 NEW COMPARE,CLNSTR1,CLNSTR2
SET COMPARE=STR1
SET TYPE=$GET(TYPE)
+10 IF COMPARE=""
QUIT ""
+11 IF TYPE="ADD"
SET STR1=$$CLNADD(STR1)
SET STR2=$$CLNADD(STR2)
+12 IF TYPE="ZIP"
SET STR1=$EXTRACT(STR1,1,5)
SET STR2=$EXTRACT(STR2,1,5)
+13 SET CLNSTR1=$$CLNSTR(STR1)
SET CLNSTR2=$$CLNSTR(STR2)
+14 IF ('$GET(IGNNULL)!(CLNSTR2'=""))
IF CLNSTR1'=CLNSTR2
IF '$$EQDATES(STR1,STR2)
Begin DoDot:1
+15 IF (CLNSTR1'?.N)
IF (CLNSTR2'?.N)
IF CLNSTR1'="MALE"
IF CLNSTR2'="MALE"
IF CLNSTR1[CLNSTR2!(CLNSTR2[CLNSTR1)
Begin DoDot:2
+16 IF MODE="RS"
SET COMPARE=$GET(IOINHI)_COMPARE_$GET(IOINORM)
+17 IF MODE="LM"
SET HIGHLN($SELECT($GET(LMLINE):LMLINE,1:LINE),POS)=$LENGTH(COMPARE)
End DoDot:2
+18 IF '$TEST
Begin DoDot:2
+19 IF MODE="RS"
SET COMPARE=$GET(IORVON)_COMPARE_$GET(IORVOFF)
+20 IF MODE="LM"
SET REVLN($SELECT($GET(LMLINE):LMLINE,1:LINE),POS)=$LENGTH(COMPARE)
End DoDot:2
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 IF MODE="RS"
SET COMPARE=$GET(IOINHI)_COMPARE_$GET(IOINORM)
+23 IF MODE="LM"
SET HIGHLN($SELECT($GET(LMLINE):LMLINE,1:LINE),POS)=$LENGTH(COMPARE)
End DoDot:1
+24 QUIT COMPARE
+25 ;
BLANKLN(MODE,NOVB) ; Add a Blank Line
+1 ;Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
+2 ; (o)NOVB - No Vertical Bar - 1: No Vertical Bar | 0/"" - Include Bar
+3 NEW XE,XV
+4 SET XE=""
SET $PIECE(XE,"_",41)=""
SET XV=""
SET $PIECE(XV,"_",$SELECT($GET(MODE)="LM":42,1:41))=""
IF '$GET(NOVB)
SET $EXTRACT(XV)="|"
+5 DO ADDLINE(MODE,NMSPC,XE,XV)
+6 QUIT
+7 ;
ADDLINE(MODE,NMSPC,ETEXT,VTEXT) ;Adds a New Line to the list
+1 ;Input: MODE - Display Mode: "RS": Roll & Scroll | "LM": ListMan
+2 ; NMSPC - ListMan Temp Global Namespace (e.g., "PSOERXP1")
+3 ; ETEXT - eRx Text to be added
+4 ; VTEXT - VistA Text to be added
+5 NEW TEXT
SET TEXT=""
+6 IF MODE="RS"
Begin DoDot:1
+7 NEW Y
SET Y=$SELECT($GET(IOSL):IOSL,1:24)-3
+8 IF '(LINE#Y)
Begin DoDot:2
+9 DO PAUSE
End DoDot:2
+10 IF '$TEST
WRITE !
+11 WRITE $GET(ETEXT),?40,$GET(VTEXT)
End DoDot:1
+12 IF MODE="LM"
Begin DoDot:1
+13 SET LINE=+$GET(LINE)
+14 IF $GET(ETEXT)'=""
SET TEXT=$GET(ETEXT)
+15 IF $GET(VTEXT)'=""
SET $EXTRACT(TEXT,40)=$GET(VTEXT)
+16 SET ^TMP(NMSPC,$JOB,LINE,0)=TEXT
End DoDot:1
+17 SET LINE=LINE+1
+18 QUIT
+19 ;
PAUSE ; Page break + erases the "Press Return..."
+1 NEW DIR,I,XX
SET DIR("A")="Press Return to continue"
SET DIR(0)="E"
DO ^DIR
+2 FOR I=1:1:26
WRITE $CHAR(8)
+3 SET $PIECE(XX," ",26)=""
WRITE XX
+4 FOR I=1:1:26
WRITE $CHAR(8)
+5 QUIT
+6 ;
EQDATES(DATE1,DATE2) ;Checks if the fields are valid dates and are the same
+1 ; Input: DATE1 - Date 1 to be compared with Date 2
+2 ; DATE2 - Date 2 to be compared with Date 1
+3 ;Output: 1 if DATE1 and DATE@ are equal | 0 if different
+4 NEW X,Y,DT1,DT2
+5 SET X=DATE1
DO ^%DT
if (Y<1)
QUIT 0
SET DT1=Y
+6 SET X=DATE2
DO ^%DT
if (Y<1)
QUIT 0
SET DT2=Y
+7 IF DT1=DT2
QUIT 1
+8 QUIT 0
+9 ;
CLNADD(ADD) ; Cleans an Address String
+1 ; Input: ADD - Address Line string to be cleaned
+2 ;Output: Cleaned Address Line string
+3 NEW REPS,REP,FIND,LIST,SYN,I,J
+4 SET ADD=" "_$$UP^XLFSTR(ADD)_" "
+5 FOR I=1:1
SET LIST=$TEXT(USPSABBS+I^PSOERUT1)
if (LIST'[";")
QUIT
Begin DoDot:1
+6 FOR J=3:1
if ($PIECE(LIST,";",J)="")
QUIT
SET SYN=$PIECE(LIST,";",J)
SET REPS($PIECE(SYN,"^",1))=$PIECE(SYN,"^",2)
End DoDot:1
+7 SET REP=""
FOR
SET REP=$ORDER(REPS(REP))
if REP=""
QUIT
Begin DoDot:1
+8 SET FIND=$FIND(ADD,REP)
IF FIND
SET ADD=$EXTRACT(ADD,1,FIND-$LENGTH(REP)-1)_REPS(REP)_$EXTRACT(ADD,FIND,9999)
End DoDot:1
+9 SET $EXTRACT(ADD,$LENGTH(ADD))=""
+10 QUIT ADD
+11 ;
CLNSTR(STR) ; Cleans String (Removes any characters different than a-A & 1-9)
+1 ; Input: STR - String to be cleaned
+2 ;Output: Cleaned string
+3 NEW CHR,CLNSTR,I
SET CLNSTR=""
+4 SET STR=$$UP^XLFSTR(STR)
IF STR?.P
QUIT STR
+5 FOR I=1:1:$LENGTH(STR)
SET CHR=$EXTRACT(STR,I)
IF (CHR?1N)!(($ASCII(CHR)>64)&($ASCII(CHR)<91))
SET CLNSTR=CLNSTR_CHR
+6 QUIT CLNSTR
+7 ;
RESET() ; Reset Video Atributes
+1 ; - Resetting list to NORMAL video attributes
+2 NEW I
+3 IF $DATA(VALMEVL)
FOR I=1:1:$GET(LASTLINE)
DO RESTORE^VALM10(I)
+4 KILL REVLN,HIGHLN,UNDERLN,BLINKLN,HIGUNDLN
+5 QUIT
+6 ;
VIDEO() ; Changes the Video Attributes for the list
+1 NEW I,LN,POS
+2 ;
+3 IF '$DATA(IORVOFF)!'$DATA(VALMEVL)
QUIT
+4 FOR I=0:1:$GET(LINE)
DO CNTRL^VALM10(I,1,80,IORVOFF_IOINORM,IORVOFF_IOINORM)
+5 SET LN=0
FOR
SET LN=$ORDER(REVLN(LN))
if 'LN
QUIT
Begin DoDot:1
+6 SET POS=0
FOR
SET POS=$ORDER(REVLN(LN,POS))
if 'POS
QUIT
Begin DoDot:2
+7 DO CNTRL^VALM10(LN,POS,REVLN(LN,POS),IORVON,IORVOFF_IOINORM)
End DoDot:2
End DoDot:1
+8 SET LN=0
FOR
SET LN=$ORDER(HIGHLN(LN))
if 'LN
QUIT
Begin DoDot:1
+9 SET POS=0
FOR
SET POS=$ORDER(HIGHLN(LN,POS))
if 'POS
QUIT
Begin DoDot:2
+10 DO CNTRL^VALM10(LN,POS,HIGHLN(LN,POS),IOINHI,IOINORM)
End DoDot:2
End DoDot:1
+11 SET LN=0
FOR
SET LN=$ORDER(UNDERLN(LN))
if 'LN
QUIT
Begin DoDot:1
+12 SET POS=0
FOR
SET POS=$ORDER(UNDERLN(LN,POS))
if 'POS
QUIT
Begin DoDot:2
+13 DO CNTRL^VALM10(LN,POS,UNDERLN(LN,POS),IOUON,IOUOFF)
End DoDot:2
End DoDot:1
+14 SET LN=0
FOR
SET LN=$ORDER(BLINKLN(LN))
if 'LN
QUIT
Begin DoDot:1
+15 SET POS=0
FOR
SET POS=$ORDER(BLINKLN(LN,POS))
if 'POS
QUIT
Begin DoDot:2
+16 DO CNTRL^VALM10(LN,POS,BLINKLN(LN,POS),IOBON,IOBOFF)
End DoDot:2
End DoDot:1
+17 SET LN=0
FOR
SET LN=$ORDER(HIGUNDLN(LN))
if 'LN
QUIT
Begin DoDot:1
+18 SET POS=0
FOR
SET POS=$ORDER(HIGUNDLN(LN,POS))
if 'POS
QUIT
Begin DoDot:2
+19 DO CNTRL^VALM10(LN,POS,HIGUNDLN(LN,POS),IOINHI_IOUON,IOUOFF_IOINORM)
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
ERXPHONE(ERXPAT,TYPE) ; Return the eRx Patient Phone # (if there is one)
+1 ; Input: ERXPAT - Pointer to ERX PATIENT (#52.46)
+2 ; TYPE - "PT": Primary Telephone | "HT": Home Telephone
+3 ;
+4 NEW ERXPHONE,COMM,Z
SET ERXPHONE=""
+5 SET COMM=0
FOR
SET COMM=$ORDER(^PS(52.46,ERXPAT,13,COMM))
if 'COMM
QUIT
Begin DoDot:1
+6 SET Z=$GET(^PS(52.46,ERXPAT,13,COMM,0))
+7 IF $PIECE(Z,"^",2)=TYPE
SET ERXPHONE=$PIECE(Z,"^",3)
End DoDot:1
IF ERXPHONE'=""
QUIT
+8 QUIT ERXPHONE
+9 ;
ADDRESS(VALUE,ADDLINE) ; Returns Address Line1, Line2, Line3... (max 39 characters)
+1 ; Input: VALUE - Complete Address (Line1+Line2+Line3)
+2 ; ADDLINE - Line of the formatted address
+3 ;Output: ADDRESS - Returns the Line # Address Text for 39-char fields
+4 NEW ADDRESS,DIWL,DIWR,X,I
+5 KILL ^UTILITY($JOB,"W")
SET X=$$TRIM^XLFSTR(VALUE)
SET DIWL=1
SET DIWR=39
DO ^DIWP
+6 SET ADDRESS=$$TRIM^XLFSTR($GET(^UTILITY($JOB,"W",1,ADDLINE,0)))
+7 KILL ^UTILITY($JOB,"W")
+8 QUIT ADDRESS
+9 ;
ERXWTHT(ERXIEN,TYPE) ; eRx Patient Weight/Height
+1 ; Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+2 ; TYPE - "WT": Weight in Kg | "HT": Height in cm
+3 ;Output: Value or ""
+4 NEW ERXWTHT,OBS,IENS,LCODE,LDATA,HUOM,WUOM,HOBDT,WOBDT,RET,IEN
+5 SET IEN=0
SET ERXWTHT=""
+6 FOR
SET IEN=$ORDER(^PS(52.49,ERXIEN,306,IEN))
if 'IEN
QUIT
Begin DoDot:1
+7 SET IENS=IEN_","_ERXIEN_","
+8 SET LCODE=$$GET1^DIQ(52.49306,IENS,1,"E")
+9 if 'LCODE
QUIT
+10 DO CSDATA^ETSLNC(LCODE,"LNC",DT,.LDATA)
+11 IF TYPE="HT"
IF $GET(LDATA("LEX",1))["BODY HEIGHT"
Begin DoDot:2
+12 SET ERXWTHT=$$GET1^DIQ(52.49306,IENS,3,"E")
+13 SET HUOM=$$UP^XLFSTR($$GET1^DIQ(52.49306,IENS,4,"E"))
+14 SET HOBDT=$PIECE($$GET1^DIQ(52.49306,IENS,6,"I"),".")
SET HOBDT=$$FMTE^XLFDT(HOBDT,"5Z")
+15 IF HUOM["IN"
SET ERXWTHT=ERXWTHT*2.54
SET $PIECE(ERXWTHT,".",2)=$EXTRACT($PIECE(ERXWTHT,".",2),1,2)
End DoDot:2
+16 IF TYPE="WT"
IF $GET(LDATA("LEX",1))["BODY WEIGHT"
Begin DoDot:2
+17 SET ERXWTHT=$$GET1^DIQ(52.49306,IENS,3,"E")
+18 SET WOBDT=$PIECE($$GET1^DIQ(52.49306,IENS,6,"I"),".")
SET WOBDT=$$FMTE^XLFDT(WOBDT,"5Z")
+19 SET WUOM=$$UP^XLFSTR($$GET1^DIQ(52.49306,IENS,4,"E"))
+20 IF WUOM["LB"
SET ERXWTHT=ERXWTHT/2.2046
SET $PIECE(ERXWTHT,".",2)=$EXTRACT($PIECE(ERXWTHT,".",2),1,2)
+21 IF WUOM="G"
SET ERXWTHT=ERXWTHT/1000
SET $PIECE(ERXWTHT,".",2)=$EXTRACT($PIECE(ERXWTHT,".",2),1,2)
End DoDot:2
End DoDot:1
+22 QUIT ERXWTHT
+23 ;
VAWTHT(DFN,TYPE) ; VistA Patient Weight/Height
+1 ; Input: DFN - Pointer to PATIENT File(#2)
+2 ; TYPE - "WT": Weight in Kg | "HT": Height in cm
+3 ;Output: Value or ""
+4 NEW WT,HT,X,Y,GMRVSTR,VM
+5 IF '$GET(DFN)
QUIT ""
+6 SET (WT,HT)=""
SET X="GMRVUTL"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:1
+7 FOR GMRVSTR="WT","HT"
SET VM=GMRVSTR
DO EN6^GMRVUTL
SET @VM=X
SET $PIECE(@VM,"^")=$EXTRACT($PIECE(@VM,"^"),4,5)_"/"_$EXTRACT($PIECE(@VM,"^"),6,7)_"/"_($EXTRACT($PIECE(@VM,"^"),1,3)+1700)
+8 SET X=$PIECE(WT,"^",8)
SET Y=$JUSTIFY(X/2.2046226,0,2)
SET $PIECE(WT,"^",9)=Y
SET X=$PIECE(HT,"^",8)
SET Y=$JUSTIFY(2.54*X,0,2)
SET $PIECE(HT,"^",9)=Y
End DoDot:1
+9 ;
+10 IF TYPE="WT"
IF $PIECE(WT,"^",8)
QUIT $PIECE(WT,"^",9)
+11 IF TYPE="HT"
IF $PIECE(HT,"^",8)
QUIT $PIECE(HT,"^",9)
+12 QUIT ""
PTPHONE ;display phone in the Single eRx View/Display mode
+1 NEW EPTPHONE,VPTPHONE
+2 SET EPTPHONE=$SELECT(VAPHS[$$CLNSTR(ERXPHON3)&(ERXPHON3'=""):ERXPHON3,VAPHS[$$CLNSTR(ERXPHON1)&(ERXPHON1'=""):ERXPHON1,VAPHS[$$CLNSTR(ERXPHON2)&(ERXPHON2'=""):ERXPHON2,1:$SELECT(ERXPHON2'="":ERXPHON2,ERXPHON1'="":ERXPHON1,1:ERXPHON3))
+3 SET VPTPHONE=$SELECT(ERXPHS[$$CLNSTR(VAPHONE2)&(VAPHONE2'=""):VAPHONE2,ERXPHS[$$CLNSTR(VAPHONE1)&(VAPHONE1'=""):VAPHONE1,1:$SELECT(VAPHONE2'="":VAPHONE2,1:VAPHONE1))
+4 SET XE="Phone: "_$$COMPARE(MODE,EPTPHONE,VPTPHONE,8,,,'DFN)
+5 SET XV="|Phone: "_$$COMPARE(MODE,VPTPHONE,EPTPHONE,48)
+6 DO ADDLINE(MODE,NMSPC,XE,XV)
+7 QUIT
+8 ;
PTADDRS ;display the patient address in the Single eRx View/Display mode
+1 if ($GET(ERXADDR)="")&($GET(VAADDR)="")
QUIT
+2 NEW XE,XV,EFULLADD,VFULLADD
SET (XE,XV,VFULLADD)=""
+3 if $GET(ERXADDR)'=""
SET XE=ERXADDR
+4 SET XE=XE_" "_ERXCITY
+5 SET XE=XE_$SELECT(ERXCITY'="":",",1:"")_ERXSTATE
+6 IF $GET(ERXCNTRY)'=""
SET XE=XE_" "_ERXCNTRY
+7 SET EFULLADD=$$CLNSTR($$CLNADD(XE_$EXTRACT(ERXZIP,1,5)))
+8 IF $LENGTH(XE_" "_$EXTRACT(ERXZIP,1,5))>38
SET XE=$EXTRACT(XE,1,30)_"..."_$EXTRACT(ERXZIP,1,5)
+9 IF '$TEST
SET XE=XE_" "_$EXTRACT(ERXZIP,1,5)
+10 IF $GET(DFN)
Begin DoDot:1
+11 SET XV=VAADDR
+12 SET XV=XV_" "_VACITY
+13 SET XV=XV_$SELECT(VACITY'="":",",1:"")_VASTATE
+14 IF $GET(VACNTRY)'=""
SET XV=XV_" "_VACNTRY
+15 SET VFULLADD=$$CLNSTR($$CLNADD(XV_$EXTRACT(VAZIP,1,5)))
+16 IF $LENGTH(XV_" "_$EXTRACT(VAZIP,1,5))>38
SET XV=$EXTRACT(XV,1,30)_"..."_$EXTRACT(VAZIP,1,5)
+17 IF '$TEST
SET XV=XV_" "_$EXTRACT(VAZIP,1,5)
End DoDot:1
+18 IF XE'=""
SET XE=" "_$$COMPARE(MODE,XE,$SELECT(EFULLADD=VFULLADD:XE,1:XV),2,"ADD",,'DFN)
+19 IF XV'=""
SET XV="| "_$$COMPARE(MODE,XV,$SELECT(EFULLADD=VFULLADD:XV,1:XE),42,"ADD")
+20 DO ADDLINE(MODE,NMSPC,XE,XV)
+21 QUIT
