PSOERUT0 ;ALB/MFR - eRx Patient - ListMan Utilities; 06/03/2023 5:14pm
;;7.0;OUTPATIENT PHARMACY;**700,750,746,769**;DEC 1997;Build 26
;
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,"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) D
. S XE="SSN : "_$$COMPARE(MODE,ERXSSN,VASSN,7,,,'DFN)
. S XV="|SSN : "_$$COMPARE(MODE,VASSN,ERXSSN,47)
. D ADDLINE(MODE,NMSPC,XE,XV)
. 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,,,'DFN)
. . . S XV="| "_$$COMPARE(MODE,$$ADDRESS(VAADDR,ADDLN),$$ADDRESS(ERXADDR,ADDLN),42)
. . . 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,1,,'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,1)
. 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 PTPHONE Q
;
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 WTHT(MODE,ERXIEN,DFN)
. . D BLANKLN(MODE)
. . D SETDIAGS^PSOERUT3(MODE,NMSPC,ERXIEN)
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)
S XV="|Height(cm): "_$$COMPARE(MODE,VAHT,ERXHT,53)
D ADDLINE(MODE,NMSPC,XE,XV)
Q
;
COMPARE(MODE,STR1,STR2,POS,ZIP,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)ZIP - Zipcode field (1: Yes | 0: No)
; (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
I COMPARE="" Q ""
I $G(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
;
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)
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)
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERUT0 15107 printed Dec 13, 2024@02:28:01 Page 2
PSOERUT0 ;ALB/MFR - eRx Patient - ListMan Utilities; 06/03/2023 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**700,750,746,769**;DEC 1997;Build 26
+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,"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)
Begin DoDot:1
+65 SET XE="SSN : "_$$COMPARE(MODE,ERXSSN,VASSN,7,,,'DFN)
+66 SET XV="|SSN : "_$$COMPARE(MODE,VASSN,ERXSSN,47)
+67 DO ADDLINE(MODE,NMSPC,XE,XV)
+68 SET XE="Sex : "_$$COMPARE(MODE,ERXSEX,VASEX,7,,,'DFN)
+69 SET XV="|Sex : "_$$COMPARE(MODE,VASEX,ERXSEX,47)
+70 ;
DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:1
+71 ; Pending Order Interface only shows Name,DOB, SSN and Sex
+72 IF $GET(PENFLG)
Begin DoDot:1
+73 DO BLANKLN(MODE)
End DoDot:1
QUIT
+74 ;
+75 IF '$GET(SDFLG)
Begin DoDot:1
+76 SET XE="Address:"
SET XV="|Address:"
DO ADDLINE(MODE,NMSPC,XE,XV)
+77 FOR ADDLN=1:1:5
Begin DoDot:2
+78 IF $$ADDRESS(ERXADDR,ADDLN)'=""!($$ADDRESS(VAADDR,ADDLN)'="")
Begin DoDot:3
+79 SET XE=" "_$$COMPARE(MODE,$$ADDRESS(ERXADDR,ADDLN),$$ADDRESS(VAADDR,ADDLN),2,,,'DFN)
+80 SET XV="| "_$$COMPARE(MODE,$$ADDRESS(VAADDR,ADDLN),$$ADDRESS(ERXADDR,ADDLN),42)
+81 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:3
End DoDot:2
+82 SET XE=" "_$$COMPARE(MODE,ERXCITY,VACITY,2,,,'DFN)
+83 SET XE=XE_$SELECT(ERXCITY'="":",",1:"")_$$COMPARE(MODE,ERXSTATE,VASTATE,$LENGTH(XE)+2,,,'DFN)
+84 SET XE=XE_" "_$$COMPARE(MODE,ERXZIP,VAZIP,$LENGTH(XE)+3,1,,'DFN)
+85 SET XV="| "_$$COMPARE(MODE,VACITY,ERXCITY,42)
+86 SET XV=XV_$SELECT(VACITY'="":",",1:"")_$$COMPARE(MODE,VASTATE,ERXSTATE,$LENGTH(XV)+41)
+87 SET XV=XV_" "_$$COMPARE(MODE,VAZIP,ERXZIP,$LENGTH(XV)+42,1)
+88 DO ADDLINE(MODE,NMSPC,XE,XV)
+89 IF $GET(ERXCNTRY)'=""!(VACNTRY'="")
Begin DoDot:2
+90 SET XE=" "_$$COMPARE(MODE,ERXCNTRY,VACNTRY,2)
SET XV="| "_$$COMPARE(MODE,VACNTRY,ERXCNTRY,42)
+91 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:2
End DoDot:1
+92 ;
+93 SET ERXPHS=$$CLNSTR(ERXPHON1)_","_$$CLNSTR(ERXPHON2)_","_$$CLNSTR(ERXPHON3)
+94 SET VAPHS=$$CLNSTR(VAPHONE1)_","_$$CLNSTR(VAPHONE2)
+95 ;
+96 IF $GET(SDFLG)
DO PTPHONE
QUIT
+97 ;
+98 IF ERXPHON3'=""
Begin DoDot:1
+99 SET XE="Primary Phone: "_$$COMPARE(MODE,ERXPHON3,$SELECT(VAPHS[$$CLNSTR(ERXPHON3):ERXPHON3,1:""),16,,,'DFN)
SET XV="|"
+100 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:1
+101 IF ERXPHON1'=""!(VAPHONE1'="")
Begin DoDot:1
+102 SET XE="Home Phone: "_$$COMPARE(MODE,ERXPHON1,$SELECT(VAPHS[$$CLNSTR(ERXPHON1):ERXPHON1,1:""),13,,,'DFN)
+103 SET XV="|Home Phone: "_$$COMPARE(MODE,VAPHONE1,$SELECT(ERXPHS[$$CLNSTR(VAPHONE1):VAPHONE1,1:""),53)
+104 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:1
+105 IF ERXPHON2'=""!(VAPHONE2'="")
Begin DoDot:1
+106 SET XE="Cell Phone: "_$$COMPARE(MODE,ERXPHON2,$SELECT(VAPHS[$$CLNSTR(ERXPHON2):ERXPHON2,1:""),13,,,'DFN)
+107 SET XV="|Cell Phone: "_$$COMPARE(MODE,VAPHONE2,$SELECT(ERXPHS[$$CLNSTR(VAPHONE2):VAPHONE2,1:""),53)
+108 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:1
+109 ;
+110 IF MODE="LM"
Begin DoDot:1
+111 IF '$GET(SDFLG)
Begin DoDot:2
+112 DO BLANKLN(MODE)
+113 SET XV="|Pharmacy Narrative: "
DO ADDLINE(MODE,NMSPC,,XV)
+114 IF $GET(DFN)
Begin DoDot:3
+115 SET X=$$GET1^DIQ(55,DFN,1,"E")
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=38
SET DIWF="|"
DO ^DIWP
+116 FOR I=1:1
if '$DATA(^UTILITY($JOB,"W",1,I))
QUIT
Begin DoDot:4
+117 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
+118 DO BLANKLN(MODE)
+119 DO ALLERGY^PSOERUT3(MODE,NMSPC,ERXIEN,$GET(DFN))
+120 DO WTHT(MODE,ERXIEN,DFN)
+121 DO BLANKLN(MODE)
+122 DO SETDIAGS^PSOERUT3(MODE,NMSPC,ERXIEN)
End DoDot:2
End DoDot:1
+123 IF '$TEST
DO BLANKLN(MODE)
+124 QUIT
+125 ;
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)
+12 SET XV="|Height(cm): "_$$COMPARE(MODE,VAHT,ERXHT,53)
+13 DO ADDLINE(MODE,NMSPC,XE,XV)
+14 QUIT
+15 ;
COMPARE(MODE,STR1,STR2,POS,ZIP,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)ZIP - Zipcode field (1: Yes | 0: No)
+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
+10 IF COMPARE=""
QUIT ""
+11 IF $GET(ZIP)
SET STR1=$EXTRACT(STR1,1,5)
SET STR2=$EXTRACT(STR2,1,5)
+12 SET CLNSTR1=$$CLNSTR(STR1)
SET CLNSTR2=$$CLNSTR(STR2)
+13 IF ('$GET(IGNNULL)!(CLNSTR2'=""))
IF CLNSTR1'=CLNSTR2
IF '$$EQDATES(STR1,STR2)
Begin DoDot:1
+14 IF (CLNSTR1'?.N)
IF (CLNSTR2'?.N)
IF CLNSTR1'="MALE"
IF CLNSTR2'="MALE"
IF CLNSTR1[CLNSTR2!(CLNSTR2[CLNSTR1)
Begin DoDot:2
+15 IF MODE="RS"
SET COMPARE=$GET(IOINHI)_COMPARE_$GET(IOINORM)
+16 IF MODE="LM"
SET HIGHLN($SELECT($GET(LMLINE):LMLINE,1:LINE),POS)=$LENGTH(COMPARE)
End DoDot:2
+17 IF '$TEST
Begin DoDot:2
+18 IF MODE="RS"
SET COMPARE=$GET(IORVON)_COMPARE_$GET(IORVOFF)
+19 IF MODE="LM"
SET REVLN($SELECT($GET(LMLINE):LMLINE,1:LINE),POS)=$LENGTH(COMPARE)
End DoDot:2
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 IF MODE="RS"
SET COMPARE=$GET(IOINHI)_COMPARE_$GET(IOINORM)
+22 IF MODE="LM"
SET HIGHLN($SELECT($GET(LMLINE):LMLINE,1:LINE),POS)=$LENGTH(COMPARE)
End DoDot:1
+23 QUIT COMPARE
+24 ;
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 ;
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)
+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)
End DoDot:2
End DoDot:1
+21 QUIT ERXWTHT
+22 ;
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
