PSJLMHED ;BIR/MLM-BUILD LM HEADERS ;29-May-2012 14:38;PLS
;;5.0; INPATIENT MEDICATIONS ;**4,58,85,110,148,1015**;16 DEC 97;Build 62
;
; 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.
; Modified - IHS/CIA/PLS - 12/05/03 - Line HDR0+8
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: "_$P(PSJPSEX,U,2),VALMHDR(4)=$$SETSTR^VALM1($S(PSJPDD:"Last ",1:" ")_"Admitted: "_$P(PSJPAD,U,2),PSJ,45,23)
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,42,26)
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) 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
; IHS/CIA/PLS - 12/05/03 - Display HRN instead of SSN
;S PSJ=" PID: "_$P(PSJPSSN,U,2)
S PSJ=" HRN: "_$G(PSJPPID)
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: "_$P($P(PSJPDOB,U,2)," ")_" ("_PSJPAGE_")",VALMHDR(3)=$$SETSTR^VALM1("Wt(kg): "_PSJPWT_" "_PSJPWTD,PSJ,55,25)
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="" D
.S PSJF="^PS("_$S("AO"[PSJC:"55,"_PSGP_",5,",1:"53.1,")
.I PSJTF'=$E(PSJC,1)!(PSJC="CC")!(PSJC="CD")!(PSJC="BD") Q:PSJC="CB" Q:PSJC="O" 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" 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,",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="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
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) 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
I $D(^TMP("PSJ",$J,PSJC)) D
.N C,X,Y S C=PSJC,Y="",$P(Y," -",40)=""
.S X=$S(C="A":"A C T I V E",C["CC":"P E N D I N G R E N E W A L S",C["CD":"P E N D I N G C O M P L E X",C["C":"P E N D I N G ",C["BD":"N O N - V E R I F I E D C O M P L E X",C["B":"N O N - V E R I F I E D",1:"N O N - A C T I V E")
.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
PSJLMHED ;BIR/MLM-BUILD LM HEADERS ;29-May-2012 14:38;PLS
+1 ;;5.0; INPATIENT MEDICATIONS ;**4,58,85,110,148,1015**;16 DEC 97;Build 62
+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 ; Modified - IHS/CIA/PLS - 12/05/03 - Line HDR0+8
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 SET PSJ=" Sex: "_$PIECE(PSJPSEX,U,2)
SET VALMHDR(4)=$$SETSTR^VALM1($SELECT(PSJPDD:"Last ",1:" ")_"Admitted: "_$PIECE(PSJPAD,U,2),PSJ,45,23)
+8 SET PSJ=" Dx: "_PSJPDX
+9 IF PSJPDD
SET VALMHDR(5)=$$SETSTR^VALM1("Discharged: "_$EXTRACT($PIECE(PSJPDD,U,2),1,8),PSJ,48,26)
+10 IF 'PSJPDD
SET VALMHDR(5)=$$SETSTR^VALM1("Last transferred: "_$$ENDTC^PSGMI(PSJPTD),PSJ,42,26)
+11 QUIT
+12 ;
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 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 ; IHS/CIA/PLS - 12/05/03 - Display HRN instead of SSN
+9 ;S PSJ=" PID: "_$P(PSJPSSN,U,2)
+10 SET PSJ=" HRN: "_$GET(PSJPPID)
+11 SET RMORDT=$SELECT($GET(PSJPDD):"Last ",1:" ")_"Room-Bed: "_$GET(PSJPRB)
+12 IF PSJCLINN]""
IF PSJAPPT
SET RMORDT="Clinic Date: "_$$ENDTC^PSGMI(PSJAPPT)
SET RMORDT=$PIECE(RMORDT," ")_" "_$PIECE(RMORDT," ",2)
+13 SET PSJ=$$SETSTR^VALM1(RMORDT,PSJ,26,28)
SET VALMHDR(2)=$$SETSTR^VALM1("Ht(cm): "_PSJPHT_" "_PSJPHTD,PSJ,55,25)
+14 SET PSJ=" DOB: "_$PIECE($PIECE(PSJPDOB,U,2)," ")_" ("_PSJPAGE_")"
SET VALMHDR(3)=$$SETSTR^VALM1("Wt(kg): "_PSJPWT_" "_PSJPWTD,PSJ,55,25)
+15 QUIT
+16 ;
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=""
QUIT
Begin DoDot:1
+7 SET PSJF="^PS("_$SELECT("AO"[PSJC:"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
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
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,",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 ;These are Non-Active Orders
IF PSJC="O"
DO TF
SET PSJTF=$EXTRACT(PSJC,1)
+19 IF PSJC="O"
SET PSJST=""
FOR
SET PSJST=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST))
IF PSJST=""
QUIT
Begin DoDot:2
+20 SET PSJS=""
FOR
SET PSJS=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST,PSJS))
IF PSJS=""
QUIT
DO ON
End DoDot:2
+21 ; END DAM changes
+22 ;
End DoDot:1
+23 SET VALMCNT=PSJLN-1
DONE ;
+1 KILL PSJC,PSJEN,PSJLN,PSJST,PSJS,CNT,PSJPRI
+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)
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
+5 QUIT
+6 ;
TF ; Set up order type header
+1 IF $DATA(^TMP("PSJ",$JOB,PSJC))
Begin DoDot:1
+2 NEW C,X,Y
SET C=PSJC
SET Y=""
SET $PIECE(Y," -",40)=""
+3 SET X=$SELECT(C="A":"A C T I V E",C["CC":"P E N D I N G R E N E W A L S",C["CD":"P E N D I N G C O M P L E X",C["C":"P E N D I N G ",C["BD":"N O N - V E R I F I E D C O M P L E X",C["B":"N O N - V E R I F I E D",1:"N O N - A C T I V
E")
+4 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
+5 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
