PSOERUT0 ;ALB/MFR - eRx Patient - ListMan Utilities; 06/03/2023 5:14pm
;;7.0;OUTPATIENT PHARMACY;**700,750**;DEC 1997;Build 6
;
SETPAT(MODE,ERXIEN,DFN,NMSPC,PENFLG) ; 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
; 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) 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)
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)
;
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 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
. 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 S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR
F I=1:1:80 W $C(8)
S $P(XX," ",80)="" W X
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 ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERUT0 14172 printed Apr 09, 2024@21:36:32 Page 2
PSOERUT0 ;ALB/MFR - eRx Patient - ListMan Utilities; 06/03/2023 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**700,750**;DEC 1997;Build 6
+2 ;
SETPAT(MODE,ERXIEN,DFN,NMSPC,PENFLG) ; 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 ; Input Global Variable: LINE - Current ListMan Line # (Default)
+7 ; Output Global Variable: (ListMan Mode ONly)
+8 ; REVLN - Array Indicating Reverse Video for Line, position and size of the string
+9 ; HIGLN - Array Indicating Highlight for Line, position and size of the string
+10 if '$GET(LINE)
SET LINE=1
SET NMSPC=$GET(NMSPC)
+11 NEW ERXPAT,X,XE,XV,DATA,ERXDM,ERR,ERXNAME,ERXDOB,ERXSEX,ERXSSN,ERXPHON1,ERXPHON2,ERXPHON3,ERXADDR,ERXCITY,ERXZIP
+12 NEW ERXSTATE,ERXCNTRY,VADM,VAPA,VANAME,VADOB,VASEX,VASSN,VAPHONE1,VAPHONE2,VAADDR,VASTATE,VACNTRY,DIFFADDR,VAZIP
+13 NEW ERXPHS,VAPHS,VACITY,ADDLN,DIWL,DIWR,DIWF
+14 ;
+15 ;eRx Patient Data
+16 SET ERXPAT=+$$GET1^DIQ(52.49,ERXIEN,.04,"I")
IF 'ERXPAT
QUIT
+17 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
+18 MERGE ERXDM=DATA(52.46,ERXPAT_",")
+19 SET ERXNAME=$EXTRACT(ERXDM(.01,"E"),1,33)
SET ERXDOB=ERXDM(.08,"E")
SET ERXSEX=ERXDM(.07,"E")
+20 SET ERXSSN=ERXDM(1.4,"E")
SET ERXPHON1=$$ERXPHONE(ERXPAT,"HT")
SET ERXPHON2=$$ERXPHONE(ERXPAT,"CP")
+21 SET ERXPHON3=$$ERXPHONE(ERXPAT,"PT")
+22 SET ERXADDR=$$TRIM^XLFSTR(ERXDM(3.1,"E"))_$SELECT($$TRIM^XLFSTR(ERXDM(3.2,"E"))'="":" "_ERXDM(3.2,"E"),1:"")
+23 SET ERXCITY=ERXDM(3.3,"E")
SET ERXSTATE=$$GET1^DIQ(5,+ERXDM(3.4,"I"),1)
+24 SET ERXZIP=ERXDM(3.5,"E")
SET ERXCNTRY=ERXDM(1.6,"E")
if ERXCNTRY="US"
SET ERXCNTRY=""
+25 ;VistA Patient Data
+26 IF '$GET(DFN)
SET DFN=+$$GET1^DIQ(52.49,ERXIEN,.05,"I")
+27 SET (VANAME,VADOB,VASSN,VASEX,VAADDR,VACITY,VASTATE,VAZIP,VACNTRY,VAPHONE1,VAPHONE2)=""
+28 IF $GET(DFN)
Begin DoDot:1
+29 DO DEM^VADPT
DO ADD^VADPT
+30 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)
+31 SET VAPHONE1=$PIECE(VAPA(8),"^")
SET VAPHONE2=$$GET1^DIQ(2,DFN,.134,"E")
SET VACITY=$PIECE(VAPA(4),"^")
+32 SET VAZIP=$PIECE(VAPA(11),"^")
SET VAADDR=$$TRIM^XLFSTR(VAPA(1))_$SELECT($$TRIM^XLFSTR(VAPA(2))'="":" "_VAPA(2),1:"")
+33 SET VAADDR=VAADDR_$SELECT($$TRIM^XLFSTR(VAPA(3))'="":" "_VAPA(3),1:"")
+34 SET VASTATE=$$GET1^DIQ(5,+VAPA(5),1)
SET VACNTRY=$$GET1^DIQ(779.004,+$GET(VAPA(25)),1.2)
+35 SET VACNTRY=$SELECT(VACNTRY="US":"",VACNTRY="CA":"CN",1:VACNTRY)
End DoDot:1
+36 ;
+37 ; - Patient Matching Header Line
+38 IF $GET(PENFLG)
Begin DoDot:1
+39 NEW AMATCH,VPATIEN,VALUSER,VALDTTM,MATCH,HDR
+40 SET AMATCH=$$GET1^DIQ(52.49,ERXIEN,1.6,"I")
SET VPATIEN=$$GET1^DIQ(52.49,ERXIEN,.05,"I")
+41 SET VALUSER=$$GET1^DIQ(52.49,ERXIEN,1.13,"E")
SET VALDTTM=$$GET1^DIQ(52.49,ERXIEN,1.14,"I")
+42 IF $$GET1^DIQ(52.49,ERXIEN,.08,"I")="RE"
IF 'VALDTTM
Begin DoDot:2
+43 SET MATCH="PREVIOUSLY MATCHED/VALIDATED (RENEWAL)"
End DoDot:2
+44 IF '$TEST
Begin DoDot:2
+45 SET MATCH=$SELECT(AMATCH=1:"AUTO-MATCHED",AMATCH=2:"AUTO-MATCHED/EDITED",VPATIEN:"MANUALLY-MATCHED",1:"")
+46 IF VALUSER'=""
IF MATCH'=""
SET MATCH=MATCH_" | VALIDATED by "_$EXTRACT(VALUSER,1,19)_" on "_$$FMTE^XLFDT(VALDTTM,"2Y")
+47 IF MATCH=""
SET MATCH="NOT MATCHED"
End DoDot:2
+48 SET MATCH="PATIENT "_MATCH
IF $LENGTH(MATCH)>80
SET MATCH=$EXTRACT(MATCH,1,78)
+49 SET HDR=""
SET $EXTRACT(HDR,(80-$LENGTH(MATCH))\2+1)=MATCH
SET $EXTRACT(HDR,81)=""
+50 SET $EXTRACT(MATCH,81)=""
+51 SET UNDERLN(LINE,1)=100
IF HDR["/EDITED"
SET BLINKLN(LINE,$FIND(HDR,"/EDITED")-6)=6
+52 DO ADDLINE(MODE,NMSPC,HDR,"")
End DoDot:1
+53 ;
+54 SET XE="Name: "_$$COMPARE(MODE,$EXTRACT(ERXNAME,1,33),VANAME,7,,,'DFN)
+55 SET XV="|Name: "_$$COMPARE(MODE,VANAME,ERXNAME,47)
+56 DO ADDLINE(MODE,NMSPC,XE,XV)
+57 IF $LENGTH(ERXNAME)>33
Begin DoDot:1
+58 SET XE=$$COMPARE(MODE,$EXTRACT(ERXNAME,34,99),"",7,,,'DFN)
+59 DO ADDLINE(MODE,NMSPC,XE)
End DoDot:1
+60 SET XE="DOB : "_$$COMPARE(MODE,ERXDOB,VADOB,7,,,'DFN)
+61 SET XV="|DOB : "_$$COMPARE(MODE,VADOB,ERXDOB,47)
+62 DO ADDLINE(MODE,NMSPC,XE,XV)
+63 SET XE="SSN : "_$$COMPARE(MODE,ERXSSN,VASSN,7,,,'DFN)
+64 SET XV="|SSN : "_$$COMPARE(MODE,VASSN,ERXSSN,47)
+65 DO ADDLINE(MODE,NMSPC,XE,XV)
+66 SET XE="Sex : "_$$COMPARE(MODE,ERXSEX,VASEX,7,,,'DFN)
+67 SET XV="|Sex : "_$$COMPARE(MODE,VASEX,ERXSEX,47)
+68 DO ADDLINE(MODE,NMSPC,XE,XV)
+69 ;
+70 ; Pending Order Interface only shows Name,DOB, SSN and Sex
+71 IF $GET(PENFLG)
Begin DoDot:1
+72 DO BLANKLN(MODE)
End DoDot:1
QUIT
+73 ;
+74 SET XE="Address:"
SET XV="|Address:"
DO ADDLINE(MODE,NMSPC,XE,XV)
+75 FOR ADDLN=1:1:5
Begin DoDot:1
+76 IF $$ADDRESS(ERXADDR,ADDLN)'=""!($$ADDRESS(VAADDR,ADDLN)'="")
Begin DoDot:2
+77 SET XE=" "_$$COMPARE(MODE,$$ADDRESS(ERXADDR,ADDLN),$$ADDRESS(VAADDR,ADDLN),2,,,'DFN)
+78 SET XV="| "_$$COMPARE(MODE,$$ADDRESS(VAADDR,ADDLN),$$ADDRESS(ERXADDR,ADDLN),42)
+79 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:2
End DoDot:1
+80 SET XE=" "_$$COMPARE(MODE,ERXCITY,VACITY,2,,,'DFN)
+81 SET XE=XE_$SELECT(ERXCITY'="":",",1:"")_$$COMPARE(MODE,ERXSTATE,VASTATE,$LENGTH(XE)+2,,,'DFN)
+82 SET XE=XE_" "_$$COMPARE(MODE,ERXZIP,VAZIP,$LENGTH(XE)+3,1,,'DFN)
+83 SET XV="| "_$$COMPARE(MODE,VACITY,ERXCITY,42)
+84 SET XV=XV_$SELECT(VACITY'="":",",1:"")_$$COMPARE(MODE,VASTATE,ERXSTATE,$LENGTH(XV)+41)
+85 SET XV=XV_" "_$$COMPARE(MODE,VAZIP,ERXZIP,$LENGTH(XV)+42,1)
+86 DO ADDLINE(MODE,NMSPC,XE,XV)
+87 IF $GET(ERXCNTRY)'=""!(VACNTRY'="")
Begin DoDot:1
+88 SET XE=" "_$$COMPARE(MODE,ERXCNTRY,VACNTRY,2)
SET XV="| "_$$COMPARE(MODE,VACNTRY,ERXCNTRY,42)
+89 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:1
+90 ;
+91 SET ERXPHS=$$CLNSTR(ERXPHON1)_","_$$CLNSTR(ERXPHON2)_","_$$CLNSTR(ERXPHON3)
+92 SET VAPHS=$$CLNSTR(VAPHONE1)_","_$$CLNSTR(VAPHONE2)
+93 IF ERXPHON3'=""
Begin DoDot:1
+94 SET XE="Primary Phone: "_$$COMPARE(MODE,ERXPHON3,$SELECT(VAPHS[$$CLNSTR(ERXPHON3):ERXPHON3,1:""),16,,,'DFN)
SET XV="|"
+95 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:1
+96 IF ERXPHON1'=""!(VAPHONE1'="")
Begin DoDot:1
+97 SET XE="Home Phone: "_$$COMPARE(MODE,ERXPHON1,$SELECT(VAPHS[$$CLNSTR(ERXPHON1):ERXPHON1,1:""),13,,,'DFN)
+98 SET XV="|Home Phone: "_$$COMPARE(MODE,VAPHONE1,$SELECT(ERXPHS[$$CLNSTR(VAPHONE1):VAPHONE1,1:""),53)
+99 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:1
+100 IF ERXPHON2'=""!(VAPHONE2'="")
Begin DoDot:1
+101 SET XE="Cell Phone: "_$$COMPARE(MODE,ERXPHON2,$SELECT(VAPHS[$$CLNSTR(ERXPHON2):ERXPHON2,1:""),13,,,'DFN)
+102 SET XV="|Cell Phone: "_$$COMPARE(MODE,VAPHONE2,$SELECT(ERXPHS[$$CLNSTR(VAPHONE2):VAPHONE2,1:""),53)
+103 DO ADDLINE(MODE,NMSPC,XE,XV)
End DoDot:1
+104 ;
+105 IF MODE="LM"
Begin DoDot:1
+106 DO BLANKLN(MODE)
+107 SET XV="|Pharmacy Narrative: "
DO ADDLINE(MODE,NMSPC,,XV)
+108 IF $GET(DFN)
Begin DoDot:2
+109 SET X=$$GET1^DIQ(55,DFN,1,"E")
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=38
SET DIWF="|"
DO ^DIWP
+110 FOR I=1:1
if '$DATA(^UTILITY($JOB,"W",1,I))
QUIT
Begin DoDot:3
+111 SET XV="| "_$$COMPARE(MODE,^UTILITY($JOB,"W",1,I,0),^UTILITY($JOB,"W",1,I,0),42)
DO ADDLINE(MODE,NMSPC,,XV)
End DoDot:3
End DoDot:2
+112 DO BLANKLN(MODE)
+113 DO ALLERGY^PSOERUT3(MODE,NMSPC,ERXIEN,$GET(DFN))
+114 DO WTHT(MODE,ERXIEN,DFN)
+115 DO BLANKLN(MODE)
+116 DO SETDIAGS^PSOERUT3(MODE,NMSPC,ERXIEN)
End DoDot:1
+117 IF '$TEST
DO BLANKLN(MODE)
+118 QUIT
+119 ;
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
SET DIR("A")="Press Return to continue"
SET DIR(0)="E"
DO ^DIR
+2 FOR I=1:1:80
WRITE $CHAR(8)
+3 SET $PIECE(XX," ",80)=""
WRITE X
+4 QUIT
+5 ;
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 ""
