- PSJLMHED ;BIR/MLM - BUILD LM HEADERS ; 8/6/14 11:00am
- ;;5.0;INPATIENT MEDICATIONS;**4,58,85,110,148,181,260,275,331,256,353,387**;16 DEC 97;Build 1
- ;
- ; Reference to ^PS(55 is supported by DBIA 2191.
- ; Reference to $$CWAD^ORQPT2 is supported by DBIA 2831.
- ; Reference to ^SC( is supported by DBIA 10040.
- ; External reference to $$BSA^PSSDSAPI supported by DBIA 5425.
- ; External reference to ^ORQQVI supported by DBIA 5770.
- ; External reference to ^ORB31 supported by DBIA 5140.
- ; External reference to ^ORQQLR1 supported by DBIA 5787.
- ;
- HDR(DFN) ; -- list screen header
- ; input: DFN := ifn of pat
- ; output: VALMHDR() := hdr array
- ;
- K VAIN,VADM,GMRA,PSJACNWP,PSJ,VAERR,VA,X
- S PSJACNWP=1 D ENBOTH^PSJAC
- D HDRO(DFN)
- S PSJ=" Sex: "_$E($P(PSJPSEX,U,2)_" ",1,17) ;353
- S PSJ=PSJ_"TrSp: "_$$GET1^DIQ(2,PSGP_",",.103),VALMHDR(4)=$$SETSTR^VALM1($S(PSJPDD:"Last ",1:" ")_"Admitted: "_$P(PSJPAD,U,2),PSJ,49,23) ;353
- S PSJ=" Dx: "_PSJPDX
- S:PSJPDD VALMHDR(5)=$$SETSTR^VALM1("Discharged: "_$E($P(PSJPDD,U,2),1,8),PSJ,48,26)
- S:'PSJPDD VALMHDR(5)=$$SETSTR^VALM1("Last transferred: "_$$ENDTC^PSGMI(PSJPTD),PSJ,49,26)
- ;
- ; Display CrCl/BSA - show serum creatinine if CrCl can't be calculated
- S PSJBSA=$$BSA^PSSDSAPI(DFN),PSJBSA=$P(PSJBSA,"^",3),PSJBSA=$S(PSJBSA'>0:"__________",1:$J(PSJBSA,4,2))
- ; RSLT -- DATE^CRCL^Serum Creatinine -- Ex. 11/25/11^68.7^1.1
- S RSLT=$$CRCL(DFN)
- ; Display format of CrCL and Creatinine results updated - PSJ*5.0*387
- I ($P($G(RSLT),"^",2)["Not Found")&($P($G(RSLT),"^",3)<.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: Not Found)"
- I ($P($G(RSLT),"^",2)["Not Found")&($P($G(RSLT),"^",3)>=.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: "_$P($G(RSLT),"^",3)_"mg/dL "_$P($G(RSLT),"^")_")"
- I ($P($G(RSLT),"^",2)'["Not Found")&($P($G(RSLT),"^",3)<.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: Not Found)"
- I ($P($G(RSLT),"^",2)'["Not Found")&($P($G(RSLT),"^",3)>=.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_"(est.)"_" (CREAT: "_$P($G(RSLT),"^",3)_"mg/dL "_$P($G(RSLT),"^")_")"
- S PSJDB=$G(ZDSPL),VALMHDR(6)=$$SETSTR^VALM1("BSA (m2): "_$G(PSJBSA),PSJDB,50,23) K PSJBSA,RSLT,ZDSPL
- Q
- ;
- HDRO(DFN) ; Standardized part of profile header.
- N PSJCLIN,PSJAPPT,PSJCLINN,RMORDT S (PSJCLIN,PSJAPPT)=0,(RMORDAT,PSJCLINN)="" I $G(PSJORD) D
- . 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:"")
- . S:PSJCLIN PSJAPPT=$P($G(PSJCLIN),U,2) S:'PSJAPPT PSJCLIN="" I PSJCLIN,PSJAPPT S PSJCLINN=$P($G(^SC(+PSJCLIN,0)),U)
- K VALMHDR I PSJCLINN]"" S PSJ=VADM(1),PSJ=$$SETSTR^VALM1(" Clinic: "_PSJCLINN,PSJ,28,26)
- I PSJCLINN="" S PSJ=VADM(1),PSJ=$$SETSTR^VALM1($S('PSJPDD:"",1:"Last ")_"Ward: "_PSJPWDN,PSJ,30,18)
- S X=$$CWAD^ORQPT2(DFN)
- S:X]"" X=IORVON_X_IORVOFF,PSJ=$$SETSTR^VALM1(X,PSJ,80-$L(X),80) S VALMHDR(1)=PSJ
- S PSJ=" PID: "_$P(PSJPSSN,U,2)
- S RMORDT=$S($G(PSJPDD):"Last ",1:"")_"Room-Bed: "_$G(PSJPRB)
- I PSJCLINN]"",PSJAPPT S RMORDT="Clinic Date: "_$$ENDTC^PSGMI(PSJAPPT),RMORDT=$P(RMORDT," ")_" "_$P(RMORDT," ",2)
- S PSJ=$$SETSTR^VALM1(RMORDT,PSJ,26,28),VALMHDR(2)=$$SETSTR^VALM1("Ht(cm): "_PSJPHT_" "_PSJPHTD,PSJ,55,25)
- S PSJ=" DOB: "_$E($P($P(PSJPDOB,U,2)," ")_" ("_PSJPAGE_")"_" ",1,17) ;*353
- S PSJ=PSJ_"Att: "_$$GET1^DIQ(2,PSGP_",",.1041),VALMHDR(3)=$$SETSTR^VALM1("Wt(kg): "_PSJPWT_" "_PSJPWTD,PSJ,55,25) ;*353
- Q
- ;
- INIT(PSJPROT) ; -- init bld vars
- ; PSJPROT=1:UD ONLY; 2:IV ONLY; 3:BOTH
- K PSJUDPRF,^TMP("PSJ",$J),^TMP("PSJON",$J),^TMP("PSJPRO",$J)
- S:PSJPROT=1 PSJUDPRF=1
- D KILL^VALM10(),EN^PSJO1(PSJPROT)
- 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
- S PSJTF=0,PSJLN=1,PSJEN=1,PSJC="" F S PSJC=$O(^TMP("PSJ",$J,PSJC)) Q:PSJC=""!(PSJC["^") D
- .S PSJF="^PS("_$S("AO"[PSJC:"55,"_PSGP_",5,",PSJC="DF":"55,"_PSGP_",5,",1:"53.1,")
- .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-07 Added Q:PSJC="CB" Q:PSJC="O"
- .S PSJST="" F S PSJST=$O(^TMP("PSJ",$J,PSJC,PSJST)) Q:PSJST="" D
- ..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 Added Q:PSJC="CB" Q:PSJC="O"
- .;
- .;DAM 8-29-07 New code to place Pending Orders after Pending Renewal Orders on the roll and scroll display. Non-Active Orders appear last.
- S PSJTF=0,PSJC="" F S PSJC=$O(^TMP("PSJ",$J,PSJC)) Q:PSJC="" D
- . S PSJF="^PS("_$S("AO"[PSJC:"55,"_PSGP_",5,",PSJC="DF":"55,"_PSGP_",5,",1:"53.1,")
- . I PSJC="CB" D TF S PSJTF=$E(PSJC,1) ;These are Pending Orders
- . I PSJC="CB" S PSJST="" F S PSJST=$O(^TMP("PSJ",$J,PSJC,PSJST)) Q:PSJST="" D
- . . S PSJS="" F S PSJS=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS)) Q:PSJS="" D ON
- . ;
- . I PSJC["Cz" D
- . . N PSJCLIN
- . . S PSJF="^PS("_$S("AO"[$P(PSJC,"^",4):"55,"_PSGP_",5,",$P(PSJC,"^",4)="DF":"55,"_PSGP_",5,",1:"53.1,")
- . . S PSJCLIN=$P(PSJC,"^",2) Q:PSJCLIN=""
- . . I ($P(PSJTF,"^",2)'=$P(PSJC,"^",2)) D TF S PSJTF=PSJC
- . . S PSJST="" F S PSJST=$O(^TMP("PSJ",$J,PSJC,PSJST)) Q:PSJST="" D
- . . . S PSJS="" F S PSJS=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS)) Q:PSJS="" D ON ;DAM 8-29-07 Added Q:PSJC="CB" Q:PSJC="O"
- . ;
- . I PSJC="DF" D TF S PSJTF=$E(PSJC,1) ;These are recently DC Orders (mv)
- . I PSJC="DF" S PSJST="" F S PSJST=$O(^TMP("PSJ",$J,PSJC,PSJST)) Q:PSJST="" D
- . . S PSJS="" F S PSJS=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS)) Q:PSJS="" D ON
- . I PSJC="O" D TF S PSJTF=$E(PSJC,1) ;These are Non-Active Orders
- . I PSJC="O" S PSJST="" F S PSJST=$O(^TMP("PSJ",$J,PSJC,PSJST)) Q:PSJST="" D
- . . S PSJS="" F S PSJS=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS)) Q:PSJS="" D ON
- .; END DAM changes
- .;
- S VALMCNT=PSJLN-1
- DONE ;
- K PSJC,PSJEN,PSJLN,PSJST,PSJS,CNT,PSJPRI,PSJORD
- Q
- ;
- ON ;
- S PSJSCHT=$S(PSJOS:PSJS,1:PSJST)
- S PSJO="" F FQ=0:0 S PSJO=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS,PSJO)) Q:PSJO="" S DN=^(PSJO) D
- .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))
- .S ^TMP("PSJON",$J,PSJEN)=PSJO,PSJL=$J(PSJEN,4) I ($P(PSJC,"^")="Cz") N PSJTMPJC S PSJTMPJC=PSJC N PSJC S PSJC=$P(PSJTMPJC,"^",4)
- .D @$S(PSJO["V":"PIV^PSJLMPRI(PSGP,PSJO,PSJF,DN)",PSJO["U":"PUD^PSJLMPRU(PSGP,PSJO,PSJF,DN)",1:"PIV^PSJLMPRI(PSGP,PSJO,PSJF,DN)") S ^TMP("PSJPRO",$J,0)=PSJEN,PSJEN=PSJEN+1
- Q
- ;
- TF ; Set up order type header
- NEW PSJDFHDR
- I $D(^TMP("PSJ",$J,PSJC)) D
- .S PSJDCEXP=$$RECDCEXP^PSJP()
- .S PSJDFHDR="RECENTLY DISCONTINUED/EXPIRED (LAST "_+$G(PSJDCEXP)_" HOURS)"
- .N C,X,Y S C=PSJC,Y="",$P(Y," -",40)=""
- .S X=$S(($G(PSJCLIN)]""):$G(PSJCLIN),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":$$TXT^PSJO("N"),C["DF":PSJDFHDR,1:$$TXT^PSJO("NA"))
- .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
- Q
- TEST ;
- N X,Y S Y="",$P(Y," -",40)=""
- 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,(80-$L(X))/2)_" "_X_$E(Y,1,(80-$L(X))/2),1,80)
- Q
- CRCL(DFN) ;
- N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW,X1,X2,RSLT,PSCR,PSRW,ABW,ZHT,PSRH,PSCXTL,PSCXTLS,SCR,SCRD,OCXT,OCXTS,SCRV,ZAGE,ZSERUM,SEX
- S RSLT="0^<Not Found>"
- S PSCR="^^^^^^0"
- S PSCXTL="" Q:'$$TERMLKUP^ORB31(.PSCXTL,"SERUM CREATININE") RSLT
- S PSCXTLS="" Q:'$$TERMLKUP^ORB31(.PSCXTLS,"SERUM SPECIMEN") RSLT
- S SCR="",OCXT=0 F S OCXT=$O(PSCXTL(OCXT)) Q:'OCXT D
- .S OCXTS=0 F S OCXTS=$O(PSCXTLS(OCXTS)) Q:'OCXTS D
- ..S SCR=$$LOCL^ORQQLR1(DFN,$P(PSCXTL(OCXT),U),$P(PSCXTLS(OCXTS),U))
- ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR
- S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT
- S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT
- S RSLT=SCRD_"^<Not Found>^"_$P($G(SCR),"^",3)
- S X1=$P(RSLT,"^"),X2=$$FMTE^XLFDT(X1,"2M"),$P(RSLT,"^")=$P(X2,"@") K X1,X2
- D VITAL^ORQQVI("WEIGHT","WT",DFN,.PSRW,0,"",$$NOW^XLFDT)
- Q:'$D(PSRW) RSLT
- S ABW=$P(PSRW(1),U,3) Q:+$G(ABW)<1 RSLT
- S ABW=ABW/2.20462262 ;ABW (actual body weight) in kg; changed 2.2 to 2.20462262 per CQ 10637 ; PSO 402
- D VITAL^ORQQVI("HEIGHT","HT",DFN,.PSRH,0,"",$$NOW^XLFDT)
- Q:'$D(PSRH) RSLT
- S ZHT=$P(PSRH(1),U,3) Q:+$G(ZHT)<1 RSLT
- N VADM D DEM^VADPT S ZAGE=$G(VADM(4)) Q:'$L(ZAGE) RSLT
- ;S ZAGE=$$AGE^ORQPTQ4(DFN) Q:'ZAGE RSLT
- S SEX=$P($G(VADM(5)),"^") Q:'$L(SEX) RSLT
- ;S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT
- I '$G(ABW)!($G(ZHT)<1)!'$G(ZAGE)!'$D(SEX) Q RSLT
- S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT
- S HTGT60=$S(ZHT>60:(ZHT-60)*2.3,1:0) ;if ht > 60 inches
- I HTGT60>0 D
- .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60) ;Ideal Body Weight
- .S BWRATIO=(ABW/IBW) ;body weight ratio
- .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0)
- .S LOWBW=$S(IBW<ABW:IBW,1:ABW)
- .I BWRATIO>1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW)
- .E S ADJBW=LOWBW
- I +$G(ADJBW)<1 D
- .S ADJBW=ABW
- S CRCL=(((140-ZAGE)*ADJBW)/(SCRV*72))
- S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1)
- S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1)
- S X1=$P(RSLT,"^"),X2=$$FMTE^XLFDT(X1,"2M"),$P(RSLT,"^")=$P(X2,"@") K X1,X2
- S $P(RSLT,"^",3)=$P($G(SCR),"^",3)
- K HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW,X1,X2,PSCR,PSRW,ABW,ZHT,PSRH,ZAGE,PSCXTL,PSCXTLS,SCR,OCXT,OCXTS,SCRV,CRCL,ZSERUM
- Q RSLT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJLMHED 9532 printed Jan 18, 2025@03:08:42 Page 2
- PSJLMHED ;BIR/MLM - BUILD LM HEADERS ; 8/6/14 11:00am
- +1 ;;5.0;INPATIENT MEDICATIONS;**4,58,85,110,148,181,260,275,331,256,353,387**;16 DEC 97;Build 1
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA 2191.
- +4 ; Reference to $$CWAD^ORQPT2 is supported by DBIA 2831.
- +5 ; Reference to ^SC( is supported by DBIA 10040.
- +6 ; External reference to $$BSA^PSSDSAPI supported by DBIA 5425.
- +7 ; External reference to ^ORQQVI supported by DBIA 5770.
- +8 ; External reference to ^ORB31 supported by DBIA 5140.
- +9 ; External reference to ^ORQQLR1 supported by DBIA 5787.
- +10 ;
- HDR(DFN) ; -- list screen header
- +1 ; input: DFN := ifn of pat
- +2 ; output: VALMHDR() := hdr array
- +3 ;
- +4 KILL VAIN,VADM,GMRA,PSJACNWP,PSJ,VAERR,VA,X
- +5 SET PSJACNWP=1
- DO ENBOTH^PSJAC
- +6 DO HDRO(DFN)
- +7 ;353
- SET PSJ=" Sex: "_$EXTRACT($PIECE(PSJPSEX,U,2)_" ",1,17)
- +8 ;353
- SET PSJ=PSJ_"TrSp: "_$$GET1^DIQ(2,PSGP_",",.103)
- SET VALMHDR(4)=$$SETSTR^VALM1($SELECT(PSJPDD:"Last ",1:" ")_"Admitted: "_$PIECE(PSJPAD,U,2),PSJ,49,23)
- +9 SET PSJ=" Dx: "_PSJPDX
- +10 if PSJPDD
- SET VALMHDR(5)=$$SETSTR^VALM1("Discharged: "_$EXTRACT($PIECE(PSJPDD,U,2),1,8),PSJ,48,26)
- +11 if 'PSJPDD
- SET VALMHDR(5)=$$SETSTR^VALM1("Last transferred: "_$$ENDTC^PSGMI(PSJPTD),PSJ,49,26)
- +12 ;
- +13 ; Display CrCl/BSA - show serum creatinine if CrCl can't be calculated
- +14 SET PSJBSA=$$BSA^PSSDSAPI(DFN)
- SET PSJBSA=$PIECE(PSJBSA,"^",3)
- SET PSJBSA=$SELECT(PSJBSA'>0:"__________",1:$JUSTIFY(PSJBSA,4,2))
- +15 ; RSLT -- DATE^CRCL^Serum Creatinine -- Ex. 11/25/11^68.7^1.1
- +16 SET RSLT=$$CRCL(DFN)
- +17 ; Display format of CrCL and Creatinine results updated - PSJ*5.0*387
- +18 IF ($PIECE($GET(RSLT),"^",2)["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
- +19 IF ($PIECE($GET(RSLT),"^",2)["Not Found")&($PIECE($GET(RSLT),"^",3)>=.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: "_$PIECE($GET(RSLT),"^",3)_"mg/dL "_$PIECE($GET(RSLT),"^")_")"
- +20 IF ($PIECE($GET(RSLT),"^",2)'["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
- +21 IF ($PIECE($GET(RSLT),"^",2)'["Not Found")&($PIECE($GET(RSLT),"^",3)>=.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_"(est.)"_" (CREAT: "_$PIECE($GET(RSLT),"^",3)_"mg/dL "_$PIECE($GET(RSLT),"^")_")"
- +22 SET PSJDB=$GET(ZDSPL)
- SET VALMHDR(6)=$$SETSTR^VALM1("BSA (m2): "_$GET(PSJBSA),PSJDB,50,23)
- KILL PSJBSA,RSLT,ZDSPL
- +23 QUIT
- +24 ;
- HDRO(DFN) ; Standardized part of profile header.
- +1 NEW PSJCLIN,PSJAPPT,PSJCLINN,RMORDT
- SET (PSJCLIN,PSJAPPT)=0
- SET (RMORDAT,PSJCLINN)=""
- IF $GET(PSJORD)
- Begin DoDot:1
- +2 SET PSJCLIN=$SELECT($GET(PSJORD)["V":$GET(^PS(55,DFN,"IV",+PSJORD,"DSS")),$GET(PSJORD)["U":$GET(^PS(55,DFN,5,+PSJORD,8)),$GET(PSJORD)["P":$GET(^PS(53.1,+PSJORD,"DSS")),1:"")
- +3 if PSJCLIN
- SET PSJAPPT=$PIECE($GET(PSJCLIN),U,2)
- if 'PSJAPPT
- SET PSJCLIN=""
- IF PSJCLIN
- IF PSJAPPT
- SET PSJCLINN=$PIECE($GET(^SC(+PSJCLIN,0)),U)
- End DoDot:1
- +4 KILL VALMHDR
- IF PSJCLINN]""
- SET PSJ=VADM(1)
- SET PSJ=$$SETSTR^VALM1(" Clinic: "_PSJCLINN,PSJ,28,26)
- +5 IF PSJCLINN=""
- SET PSJ=VADM(1)
- SET PSJ=$$SETSTR^VALM1($SELECT('PSJPDD:"",1:"Last ")_"Ward: "_PSJPWDN,PSJ,30,18)
- +6 SET X=$$CWAD^ORQPT2(DFN)
- +7 if X]""
- SET X=IORVON_X_IORVOFF
- SET PSJ=$$SETSTR^VALM1(X,PSJ,80-$LENGTH(X),80)
- SET VALMHDR(1)=PSJ
- +8 SET PSJ=" PID: "_$PIECE(PSJPSSN,U,2)
- +9 SET RMORDT=$SELECT($GET(PSJPDD):"Last ",1:"")_"Room-Bed: "_$GET(PSJPRB)
- +10 IF PSJCLINN]""
- IF PSJAPPT
- SET RMORDT="Clinic Date: "_$$ENDTC^PSGMI(PSJAPPT)
- SET RMORDT=$PIECE(RMORDT," ")_" "_$PIECE(RMORDT," ",2)
- +11 SET PSJ=$$SETSTR^VALM1(RMORDT,PSJ,26,28)
- SET VALMHDR(2)=$$SETSTR^VALM1("Ht(cm): "_PSJPHT_" "_PSJPHTD,PSJ,55,25)
- +12 ;*353
- SET PSJ=" DOB: "_$EXTRACT($PIECE($PIECE(PSJPDOB,U,2)," ")_" ("_PSJPAGE_")"_" ",1,17)
- +13 ;*353
- SET PSJ=PSJ_"Att: "_$$GET1^DIQ(2,PSGP_",",.1041)
- SET VALMHDR(3)=$$SETSTR^VALM1("Wt(kg): "_PSJPWT_" "_PSJPWTD,PSJ,55,25)
- +14 QUIT
- +15 ;
- INIT(PSJPROT) ; -- init bld vars
- +1 ; PSJPROT=1:UD ONLY; 2:IV ONLY; 3:BOTH
- +2 KILL PSJUDPRF,^TMP("PSJ",$JOB),^TMP("PSJON",$JOB),^TMP("PSJPRO",$JOB)
- +3 if PSJPROT=1
- SET PSJUDPRF=1
- +4 DO KILL^VALM10()
- DO EN^PSJO1(PSJPROT)
- +5 IF '$DATA(^TMP("PSJ",$JOB))
- WRITE !!,?22,"NO ORDERS FOUND FOR "_$SELECT(PSJOL="S":"SHORT",1:"LONG")_" PROFILE."
- SET VALMQUIT=1
- DO PAUSE^PSJLMUTL
- QUIT
- +6 SET PSJTF=0
- SET PSJLN=1
- SET PSJEN=1
- SET PSJC=""
- FOR
- SET PSJC=$ORDER(^TMP("PSJ",$JOB,PSJC))
- if PSJC=""!(PSJC["^")
- QUIT
- Begin DoDot:1
- +7 SET PSJF="^PS("_$SELECT("AO"[PSJC:"55,"_PSGP_",5,",PSJC="DF":"55,"_PSGP_",5,",1:"53.1,")
- +8 ;DAM 8-29-07 Added Q:PSJC="CB" Q:PSJC="O"
- IF PSJTF'=$EXTRACT(PSJC,1)!(PSJC="CC")!(PSJC="CD")!(PSJC="BD")
- if PSJC="CB"
- QUIT
- if PSJC="O"
- QUIT
- if PSJC="DF"
- QUIT
- DO TF
- SET PSJTF=$EXTRACT(PSJC,1)
- +9 SET PSJST=""
- FOR
- SET PSJST=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST))
- if PSJST=""
- QUIT
- Begin DoDot:2
- +10 ;DAM 8-29-07 Added Q:PSJC="CB" Q:PSJC="O"
- SET PSJS=""
- FOR
- SET PSJS=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST,PSJS))
- if PSJS=""
- QUIT
- if PSJC="CB"
- QUIT
- if PSJC="O"
- QUIT
- if PSJC="DF"
- QUIT
- DO ON
- End DoDot:2
- +11 ;
- +12 ;DAM 8-29-07 New code to place Pending Orders after Pending Renewal Orders on the roll and scroll display. Non-Active Orders appear last.
- End DoDot:1
- +13 SET PSJTF=0
- SET PSJC=""
- FOR
- SET PSJC=$ORDER(^TMP("PSJ",$JOB,PSJC))
- if PSJC=""
- QUIT
- Begin DoDot:1
- +14 SET PSJF="^PS("_$SELECT("AO"[PSJC:"55,"_PSGP_",5,",PSJC="DF":"55,"_PSGP_",5,",1:"53.1,")
- +15 ;These are Pending Orders
- IF PSJC="CB"
- DO TF
- SET PSJTF=$EXTRACT(PSJC,1)
- +16 IF PSJC="CB"
- SET PSJST=""
- FOR
- SET PSJST=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST))
- if PSJST=""
- QUIT
- Begin DoDot:2
- +17 SET PSJS=""
- FOR
- SET PSJS=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST,PSJS))
- if PSJS=""
- QUIT
- DO ON
- End DoDot:2
- +18 ;
- +19 IF PSJC["Cz"
- Begin DoDot:2
- +20 NEW PSJCLIN
- +21 SET PSJF="^PS("_$SELECT("AO"[$PIECE(PSJC,"^",4):"55,"_PSGP_",5,",$PIECE(PSJC,"^",4)="DF":"55,"_PSGP_",5,",1:"53.1,")
- +22 SET PSJCLIN=$PIECE(PSJC,"^",2)
- if PSJCLIN=""
- QUIT
- +23 IF ($PIECE(PSJTF,"^",2)'=$PIECE(PSJC,"^",2))
- DO TF
- SET PSJTF=PSJC
- +24 SET PSJST=""
- FOR
- SET PSJST=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST))
- if PSJST=""
- QUIT
- Begin DoDot:3
- +25 ;DAM 8-29-07 Added Q:PSJC="CB" Q:PSJC="O"
- SET PSJS=""
- FOR
- SET PSJS=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST,PSJS))
- if PSJS=""
- QUIT
- DO ON
- End DoDot:3
- End DoDot:2
- +26 ;
- +27 ;These are recently DC Orders (mv)
- IF PSJC="DF"
- DO TF
- SET PSJTF=$EXTRACT(PSJC,1)
- +28 IF PSJC="DF"
- SET PSJST=""
- FOR
- SET PSJST=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST))
- if PSJST=""
- QUIT
- Begin DoDot:2
- +29 SET PSJS=""
- FOR
- SET PSJS=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST,PSJS))
- if PSJS=""
- QUIT
- DO ON
- End DoDot:2
- +30 ;These are Non-Active Orders
- IF PSJC="O"
- DO TF
- SET PSJTF=$EXTRACT(PSJC,1)
- +31 IF PSJC="O"
- SET PSJST=""
- FOR
- SET PSJST=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST))
- if PSJST=""
- QUIT
- Begin DoDot:2
- +32 SET PSJS=""
- FOR
- SET PSJS=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST,PSJS))
- if PSJS=""
- QUIT
- DO ON
- End DoDot:2
- +33 ; END DAM changes
- +34 ;
- End DoDot:1
- +35 SET VALMCNT=PSJLN-1
- DONE ;
- +1 KILL PSJC,PSJEN,PSJLN,PSJST,PSJS,CNT,PSJPRI,PSJORD
- +2 QUIT
- +3 ;
- ON ;
- +1 SET PSJSCHT=$SELECT(PSJOS:PSJS,1:PSJST)
- +2 SET PSJO=""
- FOR FQ=0:0
- SET PSJO=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST,PSJS,PSJO))
- if PSJO=""
- QUIT
- SET DN=^(PSJO)
- Begin DoDot:1
- +3 NEW PRJPRI
- SET PSJPRI=$SELECT(PSJO["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSJO,.2)),"^",4),PSJO["U":$PIECE($GET(^PS(55,PSGP,5,+PSJO,.2)),"^",4),1:$PIECE($GET(^PS(53.1,+PSJO,.2)),"^",4))
- +4 SET ^TMP("PSJON",$JOB,PSJEN)=PSJO
- SET PSJL=$JUSTIFY(PSJEN,4)
- IF ($PIECE(PSJC,"^")="Cz")
- NEW PSJTMPJC
- SET PSJTMPJC=PSJC
- NEW PSJC
- SET PSJC=$PIECE(PSJTMPJC,"^",4)
- +5 DO @$SELECT(PSJO["V":"PIV^PSJLMPRI(PSGP,PSJO,PSJF,DN)",PSJO["U":"PUD^PSJLMPRU(PSGP,PSJO,PSJF,DN)",1:"PIV^PSJLMPRI(PSGP,PSJO,PSJF,DN)")
- SET ^TMP("PSJPRO",$JOB,0)=PSJEN
- SET PSJEN=PSJEN+1
- End DoDot:1
- +6 QUIT
- +7 ;
- TF ; Set up order type header
- +1 NEW PSJDFHDR
- +2 IF $DATA(^TMP("PSJ",$JOB,PSJC))
- Begin DoDot:1
- +3 SET PSJDCEXP=$$RECDCEXP^PSJP()
- +4 SET PSJDFHDR="RECENTLY DISCONTINUED/EXPIRED (LAST "_+$GET(PSJDCEXP)_" HOURS)"
- +5 NEW C,X,Y
- SET C=PSJC
- SET Y=""
- SET $PIECE(Y," -",40)=""
- +6 SET X=$SELECT(($GET(PSJCLIN)]""):$GET(PSJCLIN),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":$$TXT^PSJO("N"),C["DF":PSJDFHDR,1:$$TXT^PSJO("NA"))
- +7 SET ^TMP("PSJPRO",$JOB,PSJLN,0)=$EXTRACT($EXTRACT(Y,1,(80-$LENGTH(X))/2)_" "_X_$EXTRACT(Y,1,(80-$LENGTH(X))/2),1,80)
- SET PSJLN=PSJLN+1
- End DoDot:1
- +8 QUIT
- TEST ;
- +1 NEW X,Y
- SET Y=""
- SET $PIECE(Y," -",40)=""
- +2 FOR 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"
- WRITE !,$EXTRACT($EXTRACT(Y,1,(80-$LENGTH(X))/2)_" "_X_$EXTRACT(Y,1,(80-$LENGTH(X))/2),1,80)
- +3 QUIT
- CRCL(DFN) ;
- +1 NEW HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW,X1,X2,RSLT,PSCR,PSRW,ABW,ZHT,PSRH,PSCXTL,PSCXTLS,SCR,SCRD,OCXT,OCXTS,SCRV,ZAGE,ZSERUM,SEX
- +2 SET RSLT="0^<Not Found>"
- +3 SET PSCR="^^^^^^0"
- +4 SET PSCXTL=""
- if '$$TERMLKUP^ORB31(.PSCXTL,"SERUM CREATININE")
- QUIT RSLT
- +5 SET PSCXTLS=""
- if '$$TERMLKUP^ORB31(.PSCXTLS,"SERUM SPECIMEN")
- QUIT RSLT
- +6 SET SCR=""
- SET OCXT=0
- FOR
- SET OCXT=$ORDER(PSCXTL(OCXT))
- if 'OCXT
- QUIT
- Begin DoDot:1
- +7 SET OCXTS=0
- FOR
- SET OCXTS=$ORDER(PSCXTLS(OCXTS))
- if 'OCXTS
- QUIT
- Begin DoDot:2
- +8 SET SCR=$$LOCL^ORQQLR1(DFN,$PIECE(PSCXTL(OCXT),U),$PIECE(PSCXTLS(OCXTS),U))
- +9 IF $PIECE(SCR,U,7)>$PIECE(PSCR,U,7)
- SET PSCR=SCR
- End DoDot:2
- End DoDot:1
- +10 SET SCR=PSCR
- SET SCRV=$PIECE(SCR,U,3)
- if +$GET(SCRV)<.01
- QUIT RSLT
- +11 SET SCRD=$PIECE(SCR,U,7)
- if '$LENGTH(SCRD)
- QUIT RSLT
- +12 SET RSLT=SCRD_"^<Not Found>^"_$PIECE($GET(SCR),"^",3)
- +13 SET X1=$PIECE(RSLT,"^")
- SET X2=$$FMTE^XLFDT(X1,"2M")
- SET $PIECE(RSLT,"^")=$PIECE(X2,"@")
- KILL X1,X2
- +14 DO VITAL^ORQQVI("WEIGHT","WT",DFN,.PSRW,0,"",$$NOW^XLFDT)
- +15 if '$DATA(PSRW)
- QUIT RSLT
- +16 SET ABW=$PIECE(PSRW(1),U,3)
- if +$GET(ABW)<1
- QUIT RSLT
- +17 ;ABW (actual body weight) in kg; changed 2.2 to 2.20462262 per CQ 10637 ; PSO 402
- SET ABW=ABW/2.20462262
- +18 DO VITAL^ORQQVI("HEIGHT","HT",DFN,.PSRH,0,"",$$NOW^XLFDT)
- +19 if '$DATA(PSRH)
- QUIT RSLT
- +20 SET ZHT=$PIECE(PSRH(1),U,3)
- if +$GET(ZHT)<1
- QUIT RSLT
- +21 NEW VADM
- DO DEM^VADPT
- SET ZAGE=$GET(VADM(4))
- if '$LENGTH(ZAGE)
- QUIT RSLT
- +22 ;S ZAGE=$$AGE^ORQPTQ4(DFN) Q:'ZAGE RSLT
- +23 SET SEX=$PIECE($GET(VADM(5)),"^")
- if '$LENGTH(SEX)
- QUIT RSLT
- +24 ;S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT
- +25 IF '$GET(ABW)!($GET(ZHT)<1)!'$GET(ZAGE)!'$DATA(SEX)
- QUIT RSLT
- +26 SET SCRD=$PIECE(SCR,U,7)
- if '$LENGTH(SCRD)
- QUIT RSLT
- +27 ;if ht > 60 inches
- SET HTGT60=$SELECT(ZHT>60:(ZHT-60)*2.3,1:0)
- +28 IF HTGT60>0
- Begin DoDot:1
- +29 ;Ideal Body Weight
- SET IBW=$SELECT(SEX="M":50+HTGT60,1:45.5+HTGT60)
- +30 ;body weight ratio
- SET BWRATIO=(ABW/IBW)
- +31 SET BWDIFF=$SELECT(ABW>IBW:ABW-IBW,1:0)
- +32 SET LOWBW=$SELECT(IBW<ABW:IBW,1:ABW)
- +33 IF BWRATIO>1.3
- IF (BWDIFF>0)
- SET ADJBW=((0.3*BWDIFF)+IBW)
- +34 IF '$TEST
- SET ADJBW=LOWBW
- End DoDot:1
- +35 IF +$GET(ADJBW)<1
- Begin DoDot:1
- +36 SET ADJBW=ABW
- End DoDot:1
- +37 SET CRCL=(((140-ZAGE)*ADJBW)/(SCRV*72))
- +38 if SEX="M"
- SET RSLT=SCRD_U_$JUSTIFY(CRCL,1,1)
- +39 if SEX="F"
- SET RSLT=SCRD_U_$JUSTIFY((CRCL*.85),1,1)
- +40 SET X1=$PIECE(RSLT,"^")
- SET X2=$$FMTE^XLFDT(X1,"2M")
- SET $PIECE(RSLT,"^")=$PIECE(X2,"@")
- KILL X1,X2
- +41 SET $PIECE(RSLT,"^",3)=$PIECE($GET(SCR),"^",3)
- +42 KILL HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW,X1,X2,PSCR,PSRW,ABW,ZHT,PSRH,ZAGE,PSCXTL,PSCXTLS,SCR,OCXT,OCXTS,SCRV,CRCL,ZSERUM
- +43 QUIT RSLT