- ORWRP4V ; slc/dcm - OE/RR HDR Report Extract RPC's Vitals;9/21/05 13:21
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242
- VS ;Vitals code for HDR
- N I,IFN,IFN1,IFN2,X,X1,X2,X4,X5,XIFN,ORX,COL,CODE,I1,CNT,%DT,FAC,FACU,NODE,QUALIF,METHOD,UNIT
- K ^TMP("ORXS",$J)
- S IFN=""
- F S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN="" S XIFN=^(IFN) D
- . S X11=$P(XIFN,"^",11),X12=$P(XIFN,"^",12),X2=$P(XIFN,"^",2),FACU=X12
- . I X12="",X11,X11'=200 S FACU=$O(^DIC(4,"D",X11,0)) I FACU S FACU=$P(^DIC(4,FACU,0),"^")
- . I '$L(FACU) S FACU=$S($L($P(XIFN,"^",2)):$P(XIFN,"^",2),1:"Unknown")
- . S $P(XIFN,"^",2)=FACU,X4=$P($P(XIFN,"^",4),":",1,2),X5=$P($P(XIFN,"^",5),"~",2)
- . I $P(XIFN,"^",10)'="W",$L(X5) D
- .. S X4=9999999-$$SETDATE^ORWRP4(X4)
- .. I X4=9999999 F I=.01:.01 S X4=X4+I I '$D(^TMP("ORXS",$J,FACU,X4)) Q
- .. S ^TMP("ORXS",$J,FACU,X4)=$P(XIFN,"^",2),^TMP("ORXS",$J,FACU,X4,X5,IFN)=XIFN
- K ^TMP("ORXS1",$J),^TMP("ORXS2",$J)
- S FAC="",CNT=-1
- F S FAC=$O(^TMP("ORXS",$J,FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS",$J,FAC,IFN)) Q:IFN="" S NODE=^(IFN) D
- . D XVSET("1^"_$P(NODE,"^"),1,FAC,IFN,NODE) ;Facility
- . I $P(IFN,".")'=9999999 D XVSET("2^"_$$DATE^ORDVU(9999999-IFN),2,FAC,IFN,NODE) ; Measurement Date/Time
- . I $P(IFN,".")=9999999 D XVSET("2^"_" ",2,FAC,IFN,NODE) ; Measurement Date/Time = ""
- . S IFN1=""
- . F S IFN1=$O(^TMP("ORXS",$J,FAC,IFN,IFN1)) Q:IFN1="" S IFN2="" F S IFN2=$O(^TMP("ORXS",$J,FAC,IFN,IFN1,IFN2)) Q:IFN2="" S X=^(IFN2) D
- .. I $$UPPER^ORU(IFN1)="TEMPERATURE" D XVSET("3^"_$P(X,"^",6),3,FAC,IFN,X) D METH(X)
- .. I $$UPPER^ORU(IFN1)="PULSE" D XVSET("4^"_$P(X,"^",6),4,FAC,IFN,X) D METH(X)
- .. I $$UPPER^ORU(IFN1)="RESPIRATION" D XVSET("5^"_$P(X,"^",6),5,FAC,IFN,X) D METH(X)
- .. I $$UPPER^ORU(IFN1)="BLOOD PRESSURE" D XVSET("6^"_$P(X,"^",6),6,FAC,IFN,X) D METH(X)
- .. I $$UPPER^ORU(IFN1)="HEIGHT" D XVSET("7^"_$P(X,"^",6),7,FAC,IFN,X) D METH(X)
- .. I $$UPPER^ORU(IFN1)="WEIGHT" D XVSET("8^"_$P(X,"^",6),8,FAC,IFN,X) D METH(X)
- .. I $$UPPER^ORU(IFN1)="PAIN" D XVSET("9^"_$P(X,"^",6),9,FAC,IFN,X) D METH(X)
- .. I $$UPPER^ORU(IFN1)="PULSE OXIMETRY" D
- ... D XVSET("10^"_$P(X,"^",6),10,FAC,IFN,X) D METH(X)
- ... F I=1:1:2 D
- .... I $L($P(X,"^",13)),$P($P($P(X,"^",13),"|",I)," ",2)["l/min" D XVSET("13^"_$P($P($P(X,"^",13),"|",I)," "),13,FAC,IFN,X) ;Flow Rate
- .... I $L($P(X,"^",13)),$P($P($P(X,"^",13),"|",I)," ",2)["%" D XVSET("14^"_$P($P($P(X,"^",13),"|",I)," "),14,FAC,IFN,X) ;O2 Concentration
- .. I $$UPPER^ORU(IFN1)="CENTRAL VENOUS PRESSURE" D XVSET("11^"_$P(X,"^",6),11,FAC,IFN,X) D METH(X)
- .. I $$UPPER^ORU(IFN1)="CIRCUMFERENCE/GIRTH" D XVSET("12^"_$P(X,"^",6),12,FAC,IFN,X) D METH(X)
- S FAC=""
- F S FAC=$O(^TMP("ORXS2",$J,"METH",FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS2",$J,"METH",FAC,IFN)) Q:IFN="" S METHOD=^(IFN,1),DATA=^(0) D
- .I $L(METHOD) S X=METHOD D
- .. D XVSET("16^"_X,16,FAC,IFN,DATA) ;Methods
- S FAC=""
- F S FAC=$O(^TMP("ORXS2",$J,"QUAL",FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS2",$J,"QUAL",FAC,IFN)) Q:IFN="" S QUALIF=^(IFN,1),DATA=^(0) D
- .I $L(QUALIF) S X=QUALIF D
- .. D XVSET("15^"_X,15,FAC,IFN,DATA) ;Qualifiers
- S FAC=""
- F S FAC=$O(^TMP("ORXS2",$J,"UNIT",FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS2",$J,"UNIT",FAC,IFN)) Q:IFN="" S UNIT=^(IFN,1),DATA=^(0) D
- .I $L(UNIT) S X=UNIT D
- .. D XVSET("17^"_X,17,FAC,IFN,DATA) ;Units
- K ^XTMP(HANDLE,"D")
- S FAC="",CNT=-1
- F S FAC=$O(^TMP("ORXS1",$J,FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS1",$J,FAC,IFN)) Q:IFN="" S IFN1="" D
- . F S IFN1=$O(^TMP("ORXS1",$J,FAC,IFN,IFN1)) Q:IFN1="" S X=^(IFN1) D
- .. S CNT=CNT+1,^XTMP(HANDLE,"D",CNT)=X
- K ^TMP("ORXS",$J),^TMP("ORXS1",$J),^TMP("ORXS2",$J)
- Q
- METH(DATA) ;Get Methods, Units & Qualifiers
- Q:'$D(DATA)
- N X,D,T
- S X=$P($P(DATA,"^",3),"~",2),D=$P($G(DATA),"^",4),T=$P($P(DATA,"^",5),"~",2)
- I $L(X),$L(T),$L(D) S METHOD=$G(^TMP("ORXS2",$J,"METH",FAC,IFN,1)),METHOD=$S($L(METHOD):METHOD_" | "_T_":",1:T_":")_X,^TMP("ORXS2",$J,"METH",FAC,IFN,1)=METHOD,^(0)=DATA
- S X=$P($P(DATA,"^",8),"~",2)
- I $L(X),$L(T),$L(D) S QUALIF=$G(^TMP("ORXS2",$J,"QUAL",FAC,IFN,1)),QUALIF=$S($L(QUALIF):QUALIF_" | "_T_":",1:T_":")_X,^TMP("ORXS2",$J,"QUAL",FAC,IFN,1)=QUALIF,^(0)=DATA
- S X=$P($P(DATA,"^",7),"~",2)
- I $L(X),$L(T),$L(D) S UNIT=$G(^TMP("ORXS2",$J,"UNIT",FAC,IFN,1)),UNIT=$S($L(UNIT):UNIT_" | "_T_":",1:T_":")_X,^TMP("ORXS2",$J,"UNIT",FAC,IFN,1)=UNIT,^(0)=DATA
- Q
- XVSET(X,IFN,FAC,IDT,NODE) ;Setup Vitals nodes
- Q:'$D(X) Q:'$L($G(IDT))
- N SAVE,OIDT
- S SAVE=X
- I '$L($G(IFN)) S CNT=CNT+1,^TMP("ORXS1",$J,IDT,FAC,CNT)=$$ESCP^ORWRP4(SAVE) Q
- I $D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D Q ;Get data where item, facility, date/time are the same
- . S OIDT=IDT
- . F S IDT=IDT+.0001 Q:'$D(^TMP("ORXS1",$J,IDT,IFN))
- . I '$D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D
- .. S ^TMP("ORXS1",$J,IDT,FAC,1)=$$ESCP^ORWRP4("1^"_$P($G(NODE),"^",2)) ;Facility
- .. S ^TMP("ORXS1",$J,IDT,FAC,2)=$$ESCP^ORWRP4("2^"_$$DATE^ORDVU($$SETDATE^ORWRP4($P($G(NODE),"^",4)))) ;Date/Time
- . S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE),IDT=OIDT
- S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWRP4V 5124 printed Mar 13, 2025@21:42:23 Page 2
- ORWRP4V ; slc/dcm - OE/RR HDR Report Extract RPC's Vitals;9/21/05 13:21
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242
- VS ;Vitals code for HDR
- +1 NEW I,IFN,IFN1,IFN2,X,X1,X2,X4,X5,XIFN,ORX,COL,CODE,I1,CNT,%DT,FAC,FACU,NODE,QUALIF,METHOD,UNIT
- +2 KILL ^TMP("ORXS",$JOB)
- +3 SET IFN=""
- +4 FOR
- SET IFN=$ORDER(^XTMP(HANDLE,"D",IFN))
- if IFN=""
- QUIT
- SET XIFN=^(IFN)
- Begin DoDot:1
- +5 SET X11=$PIECE(XIFN,"^",11)
- SET X12=$PIECE(XIFN,"^",12)
- SET X2=$PIECE(XIFN,"^",2)
- SET FACU=X12
- +6 IF X12=""
- IF X11
- IF X11'=200
- SET FACU=$ORDER(^DIC(4,"D",X11,0))
- IF FACU
- SET FACU=$PIECE(^DIC(4,FACU,0),"^")
- +7 IF '$LENGTH(FACU)
- SET FACU=$SELECT($LENGTH($PIECE(XIFN,"^",2)):$PIECE(XIFN,"^",2),1:"Unknown")
- +8 SET $PIECE(XIFN,"^",2)=FACU
- SET X4=$PIECE($PIECE(XIFN,"^",4),":",1,2)
- SET X5=$PIECE($PIECE(XIFN,"^",5),"~",2)
- +9 IF $PIECE(XIFN,"^",10)'="W"
- IF $LENGTH(X5)
- Begin DoDot:2
- +10 SET X4=9999999-$$SETDATE^ORWRP4(X4)
- +11 IF X4=9999999
- FOR I=.01:.01
- SET X4=X4+I
- IF '$DATA(^TMP("ORXS",$JOB,FACU,X4))
- QUIT
- +12 SET ^TMP("ORXS",$JOB,FACU,X4)=$PIECE(XIFN,"^",2)
- SET ^TMP("ORXS",$JOB,FACU,X4,X5,IFN)=XIFN
- End DoDot:2
- End DoDot:1
- +13 KILL ^TMP("ORXS1",$JOB),^TMP("ORXS2",$JOB)
- +14 SET FAC=""
- SET CNT=-1
- +15 FOR
- SET FAC=$ORDER(^TMP("ORXS",$JOB,FAC))
- if FAC=""
- QUIT
- SET IFN=""
- FOR
- SET IFN=$ORDER(^TMP("ORXS",$JOB,FAC,IFN))
- if IFN=""
- QUIT
- SET NODE=^(IFN)
- Begin DoDot:1
- +16 ;Facility
- DO XVSET("1^"_$PIECE(NODE,"^"),1,FAC,IFN,NODE)
- +17 ; Measurement Date/Time
- IF $PIECE(IFN,".")'=9999999
- DO XVSET("2^"_$$DATE^ORDVU(9999999-IFN),2,FAC,IFN,NODE)
- +18 ; Measurement Date/Time = ""
- IF $PIECE(IFN,".")=9999999
- DO XVSET("2^"_" ",2,FAC,IFN,NODE)
- +19 SET IFN1=""
- +20 FOR
- SET IFN1=$ORDER(^TMP("ORXS",$JOB,FAC,IFN,IFN1))
- if IFN1=""
- QUIT
- SET IFN2=""
- FOR
- SET IFN2=$ORDER(^TMP("ORXS",$JOB,FAC,IFN,IFN1,IFN2))
- if IFN2=""
- QUIT
- SET X=^(IFN2)
- Begin DoDot:2
- +21 IF $$UPPER^ORU(IFN1)="TEMPERATURE"
- DO XVSET("3^"_$PIECE(X,"^",6),3,FAC,IFN,X)
- DO METH(X)
- +22 IF $$UPPER^ORU(IFN1)="PULSE"
- DO XVSET("4^"_$PIECE(X,"^",6),4,FAC,IFN,X)
- DO METH(X)
- +23 IF $$UPPER^ORU(IFN1)="RESPIRATION"
- DO XVSET("5^"_$PIECE(X,"^",6),5,FAC,IFN,X)
- DO METH(X)
- +24 IF $$UPPER^ORU(IFN1)="BLOOD PRESSURE"
- DO XVSET("6^"_$PIECE(X,"^",6),6,FAC,IFN,X)
- DO METH(X)
- +25 IF $$UPPER^ORU(IFN1)="HEIGHT"
- DO XVSET("7^"_$PIECE(X,"^",6),7,FAC,IFN,X)
- DO METH(X)
- +26 IF $$UPPER^ORU(IFN1)="WEIGHT"
- DO XVSET("8^"_$PIECE(X,"^",6),8,FAC,IFN,X)
- DO METH(X)
- +27 IF $$UPPER^ORU(IFN1)="PAIN"
- DO XVSET("9^"_$PIECE(X,"^",6),9,FAC,IFN,X)
- DO METH(X)
- +28 IF $$UPPER^ORU(IFN1)="PULSE OXIMETRY"
- Begin DoDot:3
- +29 DO XVSET("10^"_$PIECE(X,"^",6),10,FAC,IFN,X)
- DO METH(X)
- +30 FOR I=1:1:2
- Begin DoDot:4
- +31 ;Flow Rate
- IF $LENGTH($PIECE(X,"^",13))
- IF $PIECE($PIECE($PIECE(X,"^",13),"|",I)," ",2)["l/min"
- DO XVSET("13^"_$PIECE($PIECE($PIECE(X,"^",13),"|",I)," "),13,FAC,IFN,X)
- +32 ;O2 Concentration
- IF $LENGTH($PIECE(X,"^",13))
- IF $PIECE($PIECE($PIECE(X,"^",13),"|",I)," ",2)["%"
- DO XVSET("14^"_$PIECE($PIECE($PIECE(X,"^",13),"|",I)," "),14,FAC,IFN,X)
- End DoDot:4
- End DoDot:3
- +33 IF $$UPPER^ORU(IFN1)="CENTRAL VENOUS PRESSURE"
- DO XVSET("11^"_$PIECE(X,"^",6),11,FAC,IFN,X)
- DO METH(X)
- +34 IF $$UPPER^ORU(IFN1)="CIRCUMFERENCE/GIRTH"
- DO XVSET("12^"_$PIECE(X,"^",6),12,FAC,IFN,X)
- DO METH(X)
- End DoDot:2
- End DoDot:1
- +35 SET FAC=""
- +36 FOR
- SET FAC=$ORDER(^TMP("ORXS2",$JOB,"METH",FAC))
- if FAC=""
- QUIT
- SET IFN=""
- FOR
- SET IFN=$ORDER(^TMP("ORXS2",$JOB,"METH",FAC,IFN))
- if IFN=""
- QUIT
- SET METHOD=^(IFN,1)
- SET DATA=^(0)
- Begin DoDot:1
- +37 IF $LENGTH(METHOD)
- SET X=METHOD
- Begin DoDot:2
- +38 ;Methods
- DO XVSET("16^"_X,16,FAC,IFN,DATA)
- End DoDot:2
- End DoDot:1
- +39 SET FAC=""
- +40 FOR
- SET FAC=$ORDER(^TMP("ORXS2",$JOB,"QUAL",FAC))
- if FAC=""
- QUIT
- SET IFN=""
- FOR
- SET IFN=$ORDER(^TMP("ORXS2",$JOB,"QUAL",FAC,IFN))
- if IFN=""
- QUIT
- SET QUALIF=^(IFN,1)
- SET DATA=^(0)
- Begin DoDot:1
- +41 IF $LENGTH(QUALIF)
- SET X=QUALIF
- Begin DoDot:2
- +42 ;Qualifiers
- DO XVSET("15^"_X,15,FAC,IFN,DATA)
- End DoDot:2
- End DoDot:1
- +43 SET FAC=""
- +44 FOR
- SET FAC=$ORDER(^TMP("ORXS2",$JOB,"UNIT",FAC))
- if FAC=""
- QUIT
- SET IFN=""
- FOR
- SET IFN=$ORDER(^TMP("ORXS2",$JOB,"UNIT",FAC,IFN))
- if IFN=""
- QUIT
- SET UNIT=^(IFN,1)
- SET DATA=^(0)
- Begin DoDot:1
- +45 IF $LENGTH(UNIT)
- SET X=UNIT
- Begin DoDot:2
- +46 ;Units
- DO XVSET("17^"_X,17,FAC,IFN,DATA)
- End DoDot:2
- End DoDot:1
- +47 KILL ^XTMP(HANDLE,"D")
- +48 SET FAC=""
- SET CNT=-1
- +49 FOR
- SET FAC=$ORDER(^TMP("ORXS1",$JOB,FAC))
- if FAC=""
- QUIT
- SET IFN=""
- FOR
- SET IFN=$ORDER(^TMP("ORXS1",$JOB,FAC,IFN))
- if IFN=""
- QUIT
- SET IFN1=""
- Begin DoDot:1
- +50 FOR
- SET IFN1=$ORDER(^TMP("ORXS1",$JOB,FAC,IFN,IFN1))
- if IFN1=""
- QUIT
- SET X=^(IFN1)
- Begin DoDot:2
- +51 SET CNT=CNT+1
- SET ^XTMP(HANDLE,"D",CNT)=X
- End DoDot:2
- End DoDot:1
- +52 KILL ^TMP("ORXS",$JOB),^TMP("ORXS1",$JOB),^TMP("ORXS2",$JOB)
- +53 QUIT
- METH(DATA) ;Get Methods, Units & Qualifiers
- +1 if '$DATA(DATA)
- QUIT
- +2 NEW X,D,T
- +3 SET X=$PIECE($PIECE(DATA,"^",3),"~",2)
- SET D=$PIECE($GET(DATA),"^",4)
- SET T=$PIECE($PIECE(DATA,"^",5),"~",2)
- +4 IF $LENGTH(X)
- IF $LENGTH(T)
- IF $LENGTH(D)
- SET METHOD=$GET(^TMP("ORXS2",$JOB,"METH",FAC,IFN,1))
- SET METHOD=$SELECT($LENGTH(METHOD):METHOD_" | "_T_":",1:T_":")_X
- SET ^TMP("ORXS2",$JOB,"METH",FAC,IFN,1)=METHOD
- SET ^(0)=DATA
- +5 SET X=$PIECE($PIECE(DATA,"^",8),"~",2)
- +6 IF $LENGTH(X)
- IF $LENGTH(T)
- IF $LENGTH(D)
- SET QUALIF=$GET(^TMP("ORXS2",$JOB,"QUAL",FAC,IFN,1))
- SET QUALIF=$SELECT($LENGTH(QUALIF):QUALIF_" | "_T_":",1:T_":")_X
- SET ^TMP("ORXS2",$JOB,"QUAL",FAC,IFN,1)=QUALIF
- SET ^(0)=DATA
- +7 SET X=$PIECE($PIECE(DATA,"^",7),"~",2)
- +8 IF $LENGTH(X)
- IF $LENGTH(T)
- IF $LENGTH(D)
- SET UNIT=$GET(^TMP("ORXS2",$JOB,"UNIT",FAC,IFN,1))
- SET UNIT=$SELECT($LENGTH(UNIT):UNIT_" | "_T_":",1:T_":")_X
- SET ^TMP("ORXS2",$JOB,"UNIT",FAC,IFN,1)=UNIT
- SET ^(0)=DATA
- +9 QUIT
- XVSET(X,IFN,FAC,IDT,NODE) ;Setup Vitals nodes
- +1 if '$DATA(X)
- QUIT
- if '$LENGTH($GET(IDT))
- QUIT
- +2 NEW SAVE,OIDT
- +3 SET SAVE=X
- +4 IF '$LENGTH($GET(IFN))
- SET CNT=CNT+1
- SET ^TMP("ORXS1",$JOB,IDT,FAC,CNT)=$$ESCP^ORWRP4(SAVE)
- QUIT
- +5 ;Get data where item, facility, date/time are the same
- IF $DATA(^TMP("ORXS1",$JOB,IDT,FAC,IFN))
- Begin DoDot:1
- +6 SET OIDT=IDT
- +7 FOR
- SET IDT=IDT+.0001
- if '$DATA(^TMP("ORXS1",$JOB,IDT,IFN))
- QUIT
- +8 IF '$DATA(^TMP("ORXS1",$JOB,IDT,FAC,IFN))
- Begin DoDot:2
- +9 ;Facility
- SET ^TMP("ORXS1",$JOB,IDT,FAC,1)=$$ESCP^ORWRP4("1^"_$PIECE($GET(NODE),"^",2))
- +10 ;Date/Time
- SET ^TMP("ORXS1",$JOB,IDT,FAC,2)=$$ESCP^ORWRP4("2^"_$$DATE^ORDVU($$SETDATE^ORWRP4($PIECE($GET(NODE),"^",4))))
- End DoDot:2
- +11 SET ^TMP("ORXS1",$JOB,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE)
- SET IDT=OIDT
- End DoDot:1
- QUIT
- +12 SET ^TMP("ORXS1",$JOB,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE)
- +13 QUIT
