ROUTINE PSJLMHED*4,58,85,110,148,181,260*

ROUTINE PSJLMHED
PSJLMHED * * 136 LINES,  7779 BYTES,  RSUM: 20609137/50472528 Page 1 UCI: EHR,EHR   Site: Central Regional Hospital MAY 17,2015@23:33

PSJLMHED^PSJLMHED INTEGRATION AGREEMENTS
IA 2191 IA 2831 IA 10040 IA 5425 IA 5770 IA 5785 IA 5140 IA 5787

PSJLMHED^PSJLMHED REFERS TO
1 PSJLMHED -- ;BIR/MLM-BUILD LM HEADERS ;28 Jan 98 / 2:18 PM 2 +1     ;;5.0;INPATIENT MEDICATIONS;**4,58,85,110,148,181,260**;16 DEC 97;B uild 94 3 +2    ;  4 +3     ; Reference to ^PS(55 is supported by DBIA 2191.  5 +4     ; Reference to CWAD^ORQPT2 is supported by DBIA 2831.  6 +5     ; Reference to ^SC is supported by DBIA 10040.  7 +6     ;External reference to $$BSA^PSSDSAPI supported by DBIA 5425.  8 +7     ;External reference to ^ORQQVI supported by DBIA 5770.  9 +8     ;External reference to ^ORQPTQ4 supported by DBIA 5785. 10 +9     ;External reference to ^ORB31 supported by DBIA 5140. 11 +10    ;External reference to ^ORQQLR1 supported by DBIA 5787. 12 +11    ;
 * GLOBAL ^PS(55 GLOBAL ^SC ROUTINE ORQPT2 ROUTINE PSSDSAPI

HDR(DFN)^PSJLMHED CALLS

 * ENBOTH^PSJAC $SETSTR^VALM1 $BSA^PSSDSAPI $ENDTC^PSGMI

HDR(DFN)^PSJLMHED CODE
13 HDR(DFN) -- ; -- list screen header 14 +1    ;   input:       DFN := ifn of pat 15 +2    ;  output:  VALMHDR := hdr array 16 +3    ; 17 +4     K VAIN,VADM,GMRA,PSJACNWP,PSJ,VAERR,VA,X 18 +5    S PSJACNWP=1 D ENBOTH^PSJAC 19 +6    D HDRO(DFN) 20 +7    S PSJ="   Sex: "_$P(PSJPSEX,U,2),VALMHDR(4)=$$SETSTR^VALM1($S(PSJPD D:"Last ",1:"    ")_"Admitted: "_$P(PSJPAD,U,2),PSJ,45,23) 21 +8    S PSJ="    Dx: "_PSJPDX 22 +9    S:PSJPDD VALMHDR(5)=$$SETSTR^VALM1("Discharged: "_$E($P(PSJPDD,U,2) ,1,8),PSJ,48,26) 23 +10   S:'PSJPDD VALMHDR(5)=$$SETSTR^VALM1("Last transferred: "_$$ENDTC^PS            GMI(PSJPTD),PSJ,42,26) 24 +11   S PSJBSA=$$BSA^PSSDSAPI(DFN),PSJBSA=$P(PSJBSA,"^",3),PSJBSA=$S(PSJB            SA'>0:"__________",1:$J(PSJBSA,4,2)) 25 +12   S RSLT=$$CRCL(DFN) 26 +13   I $P(RSLT,"^",2)["Not Found" S ZDSPL="  CrCL: "_$P(RSLT,"^",2) 27 +14   E  S ZDSPL=" CrCL: "_$P($G(RSLT),"^",2)_"(est.) "_"(CREAT:"_$P($G(R            SLT),"^",3)_"mg/dL "_$P($G(RSLT),"^")_")" 28 +15   S PSJDB=$G(ZDSPL),VALMHDR(6)=$$SETSTR^VALM1("BSA (m2): "_$G(PSJBSA)            ,PSJDB,50,23) K PSJBSA 29 +16   Q 30 +17    ;

HDRO(DFN)^PSJLMHED CODE
31 HDRO(DFN) -- ; Standardized part of profile header. 32 +1    N PSJCLIN,PSJAPPT,PSJCLINN,RMORDT S (PSJCLIN,PSJAPPT)=0,(RMORDAT,PS            JCLINN)="" I $G(PSJORD) D 33 +2. S PSJCLIN=$S($G(PSJORD)["V":$G(^PS(55,DFN,"IV",+PSJORD,"DSS")),$G           (PSJORD)["U":$G(^PS(55,DFN,5,+PSJORD,8)),$G(PSJORD)["P":$G(^PS(53.            1,+PSJORD,"DSS")),1:"") 34 +3    . S:PSJCLIN PSJAPPT=$P($G(PSJCLIN),U,2) I PSJCLIN,PSJAPPT S PSJCLIN N=$P($G(^SC(+PSJCLIN,0)),U) 35 +4    K VALMHDR I PSJCLINN]"" S PSJ=VADM(1),PSJ=$$SETSTR^VALM1("   Clinic            : "_PSJCLINN,PSJ,28,26) 36 +5    I PSJCLINN="" S PSJ=VADM(1),PSJ=$$SETSTR^VALM1($S('PSJPDD:"     ",1 :"Last ")_"Ward: "_PSJPWDN,PSJ,30,18) 37 +6    S X=$$CWAD^ORQPT2(DFN) 38 +7    S:X]"" X=IORVON_X_IORVOFF,PSJ=$$SETSTR^VALM1(X,PSJ,80-$L(X),80) S V            ALMHDR(1)=PSJ 39 +8    S PSJ="   PID: "_$P(PSJPSSN,U,2) 40 +9    S RMORDT=$S($G(PSJPDD):"Last ",1:"     ")_"Room-Bed: "_$G(PSJPRB) 41 +10   I PSJCLINN]"",PSJAPPT S RMORDT="Clinic Date: "_$$ENDTC^PSGMI(PSJAPP            T),RMORDT=$P(RMORDT,"  ")_" "_$P(RMORDT,"  ",2) 42 +11   S PSJ=$$SETSTR^VALM1(RMORDT,PSJ,26,28),VALMHDR(2)=$$SETSTR^VALM1("H            t(cm): "_PSJPHT_" "_PSJPHTD,PSJ,55,25) 43 +12   S PSJ="   DOB: "_$P($P(PSJPDOB,U,2)," ")_" ("_PSJPAGE_")",VALMHDR(3            )=$$SETSTR^VALM1("Wt(kg): "_PSJPWT_" "_PSJPWTD,PSJ,55,25) 44 +13   Q 45 +14    ;

INIT(PSJPROT)^PSJLMHED CODE
46 INIT(PSJPROT) -- ; -- init bld vars 47 +1    ; PSJPROT=1:UD ONLY; 2:IV ONLY; 3:BOTH 48 +2    K PSJUDPRF,^TMP("PSJ",$J),^TMP("PSJON",$J),^TMP("PSJPRO",$J) 49 +3    S:PSJPROT=1 PSJUDPRF=1 50 +4    D KILL^VALM10,EN^PSJO1(PSJPROT) 51 +5    I '$D(^TMP("PSJ",$J)) W !!,?22,"NO ORDERS FOUND FOR "_$S(PSJOL="S":            "SHORT",1:"LONG")_" PROFILE." S VALMQUIT=1 D PAUSE^PSJLMUTL Q 52 +6    S PSJTF=0,PSJLN=1,PSJEN=1,PSJC="" F  S PSJC=$O(^TMP("PSJ",$J,PSJC)) Q:PSJC="" D 53 +7     .S PSJF="^PS("_$S("AO"[PSJC:"55,"_PSGP_",5,",PSJC="DF":"55,"_PSGP_"            ,5,",1:"53.1,") 54 +8     .I PSJTF'=$E(PSJC,1)!(PSJC="CC")!(PSJC="CD")!(PSJC="BD") Q:PSJC="CB            "  Q:PSJC="O"  Q:PSJC="DF"  D TF S PSJTF=$E(PSJC,1)    ;DAM 8-29-0            7 Added Q:PSJC="CB"  Q:PSJC="O" 55 +9     .S PSJST="" F  S PSJST=$O(^TMP("PSJ",$J,PSJC,PSJST)) Q:PSJST=""  D 56 +10    .. S PSJS="" F  S PSJS=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS)) Q:PSJS=""              Q:PSJC="CB"  Q:PSJC="O"  Q:PSJC="DF"  D ON      ;DAM 8-29-07  Ad            ded Q:PSJC="CB"  Q:PSJC="O" 57 +11    .; 58 +12    .;DAM 8-29-07   New code to place Pending Orders after Pending Rene            wal Orders on the roll and scroll display.  Non-Active Orders appe            ar last. 59 +13    S PSJTF=0,PSJC="" F  S PSJC=$O(^TMP("PSJ",$J,PSJC)) Q:PSJC=""  D 60 +14    . S PSJF="^PS("_$S("AO"[PSJC:"55,"_PSGP_",5,",PSJC="DF":"55,"_PSGP_ ",5,",1:"53.1,") 61 +15   . I PSJC="CB" D TF S PSJTF=$E(PSJC,1)                            ;T            hese are Pending Orders 62 +16    . I PSJC="CB" S PSJST="" F  S PSJST=$O(^TMP("PSJ",$J,PSJC,PSJST)) Q            :PSJST=""  D 63 +17    . . S PSJS="" F  S PSJS=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS)) Q:PSJS="            "   D ON 64 +18    . I PSJC="DF" D TF S PSJTF=$E(PSJC,1)                                          ;These are recently DC Orders (mv) 65 +19    . I PSJC="DF" S PSJST="" F  S PSJST=$O(^TMP("PSJ",$J,PSJC,PSJST)) Q            :PSJST=""  D 66 +20    . . S PSJS="" F  S PSJS=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS)) Q:PSJS="            "   D ON 67 +21    . I PSJC="O" D TF S PSJTF=$E(PSJC,1)                              ;            These are Non-Active Orders 68 +22    . I PSJC="O" S PSJST="" F  S PSJST=$O(^TMP("PSJ",$J,PSJC,PSJST)) Q:            PSJST=""  D 69 +23    . . S PSJS="" F  S PSJS=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS)) Q:PSJS=" "  D ON 70 +24    .; END DAM changes 71 +25    .; 72 +26    S VALMCNT=PSJLN-1

DONE^PSJLMHED CODE
73 DONE  ; 74 +1    K PSJC,PSJEN,PSJLN,PSJST,PSJS,CNT,PSJPRI 75 +2    Q 76 +3     ;

ON^PSJLMHED CODE
77 ON    ; 78 +1    S PSJSCHT=$S(PSJOS:PSJS,1:PSJST) 79 +2    S PSJO="" F FQ=0:0 S PSJO=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS,PSJO)) Q            :PSJO=""  S DN=^(PSJO)   D 80 +3     .N PRJPRI S PSJPRI=$S(PSJO["V":$P($G(^PS(55,PSGP,"IV",+PSJO,.2)),"^            ",4),PSJO["U":$P($G(^PS(55,PSGP,5,+PSJO,.2)),"^",4),1:$P($G(^PS(53 .1,+PSJO,.2)),"^",4)) 81 +4    .S ^TMP("PSJON",$J,PSJEN)=PSJO,PSJL=$J(PSJEN,4) D @$S(PSJO["V":"PIV            ^PSJLMPRI(PSGP,PSJO,PSJF,DN)",PSJO["U":"PUD^PSJLMPRU(PSGP,PSJO,PSJ            F,DN)",1:"PIV^PSJLMPRI(PSGP,PSJO,PSJF,DN)") S ^TMP("PSJPRO",$J,0)= PSJEN,PSJEN=PSJEN+1 82 +5    Q 83 +6     ;

TF^PSJLMHED CODE
84 TF    ; Set up order type header 85 +1    NEW PSJDFHDR 86 +2    I $D(^TMP("PSJ",$J,PSJC)) D 87 +3     .S PSJDCEXP=$$RECDCEXP^PSJP 88 +4    .S PSJDFHDR="RECENTLY DISCONTINUED/EXPIRED (LAST "_+$G(PSJDCEXP)_"             HOURS)" 89 +5    .N C,X,Y S C=PSJC,Y="",$P(Y," -",40)="" 90 +6    .S X=$S(C="A":$$TXT^PSJO("A"),C["CC":$$TXT^PSJO("PR"),C["CD":$$TXT^            PSJO("PC"),C["C":$$TXT^PSJO("P"),C["BD":$$TXT^PSJO("NC"),C["B":$$T            XT^PSJO("N"),C["DF":PSJDFHDR,1:$$TXT^PSJO("NA")) 91 +7    .S ^TMP("PSJPRO",$J,PSJLN,0)=$E($E(Y,1,(80-$L(X))/2)_" "_X_$E(Y,1,(            80-$L(X))/2),1,80),PSJLN=PSJLN+1 92 +8    Q

TEST^PSJLMHED CODE
93 TEST  ; 94 +1    N X,Y S Y="",$P(Y," -",40)="" 95 +2    F X="A C T I V E","P E N D I N G   R E N E W A L S","P E N D I N G             ","N O N - V E R I F I E D","N O N - A C T I V E" W !,$E($E(Y,1,(8            0-$L(X))/2)_" "_X_$E(Y,1,(80-$L(X))/2),1,80) 96 +3    Q

CRCL(DFN)^PSJLMHED CODE
97 CRCL(DFN) -- ; 98 +1    N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW,X1,X2,RSLT,PSCR,PSRW,AB W,ZHT,PSRH,PSCXTL,PSCXTLS,SCR,OCXT,OCXTS,SCRV,ZAGE,SEX 99 +2    S RSLT="0^" 100 +3    S PSCR="^^^^^^0" 101 +4    D VITAL^ORQQVI("WEIGHT","WT",DFN,.PSRW,0,"",$$NOW^XLFDT) 102 +5    Q:'$D(PSRW) RSLT 103 +6    S ABW=$P(PSRW(1),U,3) Q:+$G(ABW)<1 RSLT 104 +7    S ABW=ABW/2.2  ;ABW (actual body weight) in kg 105 +8     D VITAL^ORQQVI("HEIGHT","HT",DFN,.PSRH,0,"",$$NOW^XLFDT) 106 +9    Q:'$D(PSRH) RSLT 107 +10   S ZHT=$P(PSRH(1),U,3) Q:+$G(ZHT)<1 RSLT 108 +11   S ZAGE=$$AGE^ORQPTQ4(DFN) Q:'ZAGE RSLT 109 +12   S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT 110 +13   S PSCXTL="" Q:'$$TERMLKUP^ORB31(.PSCXTL,"SERUM CREATININE") RSLT 111 +14   S PSCXTLS="" Q:'$$TERMLKUP^ORB31(.PSCXTLS,"SERUM SPECIMEN") RSLT 112 +15   S SCR="",OCXT=0 F  S OCXT=$O(PSCXTL(OCXT)) Q:'OCXT  D 113 +16    .S OCXTS=0 F  S OCXTS=$O(PSCXTLS(OCXTS)) Q:'OCXTS  D 114 +17    ..S SCR=$$LOCL^ORQQLR1(DFN,$P(PSCXTL(OCXT),U),$P(PSCXTLS(OCXTS),U)) 115 +18   ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR 116 +19   S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT 117 +20   S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT 118 +21   ; 119 +22    S HTGT60=$S(ZHT>60:(ZHT-60)*2.3,1:0)  ;if ht > 60 inches 120 +23   I HTGT60>0 D 121 +24    .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60)  ;Ideal Body Weight 122 +25   .S BWRATIO=(ABW/IBW)  ;body weight ratio 123 +26   .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0) 124 +27   .S LOWBW=$S(IBW1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW) 126 +29   .E  S ADJBW=LOWBW 127 +30   I +$G(ADJBW)<1 D 128 +31    .S ADJBW=ABW 129 +32   S CRCL=(((140-ZAGE)*ADJBW)/(SCRV*72)) 130 +33   ; 131 +34    S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1) 132 +35   S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1) 133 +36   S X1=$P(RSLT,"^"),X2=$$FMTE^XLFDT(X1,"2M"),$P(RSLT,"^")=$P(X2,"@") K X1,X2 134 +37   S $P(RSLT,"^",3)=$P($G(SCR),"^",3) 135 +38   K HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW,X1,X2,PSCR,PSRW,ABW,ZHT ,PSRH,ZAGE,PSCXTL,PSCXTLS,SCR,OCXT,OCXTS,SCRV,CRCL 136 +39   Q RSLT