ORWRP4A ; slc/dcm - OE/RR HDR Report Extract RPC's Allergies ;9/21/05 13:21
;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997
ADR ;Allergy code for HDR
N IFN,IFN1,IFN2,X,X1,X2,X5,X6,X10,XIFN,ORX,COL,CODE,I1,CNT,%DT,FAC,FACU,NKA
K ^TMP("ORXS",$J)
S IFN=""
F S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN="" S XIFN=^(IFN),X6=$P(XIFN,"^",6),X5=$P($P(XIFN,"^",5),"~",2),X2=$S($L($P(XIFN,"^",2)):$P(XIFN,"^",2),1:"Unknown") D
. I $P(XIFN,"^",3)'="EE",$L(X5),X5'="YES",X5'="NO",X6'="ASSESSMENT" S NKA(X2)=1
S IFN=""
F S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN="" S XIFN=^(IFN) D
. S X2=$P(XIFN,"^",2),FACU=X2
. I X2?1N.N S FACU=$O(^DIC(4,"D",X2,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,X10=$P($P(XIFN,"^",10),":",1,2),X6=$P(XIFN,"^",6),X5=$P($P(XIFN,"^",5),"~",2)
. I $P(XIFN,"^",3)'="EE",$L(X5),X5'="YES",X5'="NO" D
.. I X6="ASSESSMENT" S $P(XIFN,"^",10)="" I $G(NKA(X2)) Q
.. S X10=9999999-$$SETDATE^ORWRP4(X10),^TMP("ORXS",$J,FACU,$S($L(X10):X10,1:9999999),X6,IFN)=XIFN
K ^TMP("ORXS1",$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="" D
. 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
.. D XSET^ORWRP4("1^"_$P(X,"^",2)) ; Facility
.. D XSET^ORWRP4("2^"_$S(IFN1="ASSESSMENT":"NKA",1:IFN1)) ; Allergy Reactant
.. D XSET^ORWRP4("3^"_$P($P(X,"^",4),"~",2)) ; Allergy Type
.. I $L($P(X,"^",10)) S X10=$$SETDATE^ORWRP4($P(X,"^",10)) D XSET^ORWRP4("4^"_$$DATE^ORDVU(X10))
.. I '$L($P(X,"^",10)) D XSET^ORWRP4("4^"_$P(X,"^",10))
.. D XSET^ORWRP4("5^"_$P($P(X,"^",11),"~",2)) ; Observed/Historical
.. D COM^ORWRP4(6,$P(X,"^",12)) ;Comments
K ^XTMP(HANDLE,"D") M ^XTMP(HANDLE,"D")=^TMP("ORXS1",$J) K ^TMP("ORXS",$J),^TMP("ORXS1",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWRP4A 1950 printed Dec 13, 2024@02:37:22 Page 2
ORWRP4A ; slc/dcm - OE/RR HDR Report Extract RPC's Allergies ;9/21/05 13:21
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997
ADR ;Allergy code for HDR
+1 NEW IFN,IFN1,IFN2,X,X1,X2,X5,X6,X10,XIFN,ORX,COL,CODE,I1,CNT,%DT,FAC,FACU,NKA
+2 KILL ^TMP("ORXS",$JOB)
+3 SET IFN=""
+4 FOR
SET IFN=$ORDER(^XTMP(HANDLE,"D",IFN))
if IFN=""
QUIT
SET XIFN=^(IFN)
SET X6=$PIECE(XIFN,"^",6)
SET X5=$PIECE($PIECE(XIFN,"^",5),"~",2)
SET X2=$SELECT($LENGTH($PIECE(XIFN,"^",2)):$PIECE(XIFN,"^",2),1:"Unknown")
Begin DoDot:1
+5 IF $PIECE(XIFN,"^",3)'="EE"
IF $LENGTH(X5)
IF X5'="YES"
IF X5'="NO"
IF X6'="ASSESSMENT"
SET NKA(X2)=1
End DoDot:1
+6 SET IFN=""
+7 FOR
SET IFN=$ORDER(^XTMP(HANDLE,"D",IFN))
if IFN=""
QUIT
SET XIFN=^(IFN)
Begin DoDot:1
+8 SET X2=$PIECE(XIFN,"^",2)
SET FACU=X2
+9 IF X2?1N.N
SET FACU=$ORDER(^DIC(4,"D",X2,0))
IF FACU
SET FACU=$PIECE(^DIC(4,FACU,0),"^")
+10 IF '$LENGTH(FACU)
SET FACU=$SELECT($LENGTH($PIECE(XIFN,"^",2)):$PIECE(XIFN,"^",2),1:"Unknown")
+11 SET $PIECE(XIFN,"^",2)=FACU
SET X10=$PIECE($PIECE(XIFN,"^",10),":",1,2)
SET X6=$PIECE(XIFN,"^",6)
SET X5=$PIECE($PIECE(XIFN,"^",5),"~",2)
+12 IF $PIECE(XIFN,"^",3)'="EE"
IF $LENGTH(X5)
IF X5'="YES"
IF X5'="NO"
Begin DoDot:2
+13 IF X6="ASSESSMENT"
SET $PIECE(XIFN,"^",10)=""
IF $GET(NKA(X2))
QUIT
+14 SET X10=9999999-$$SETDATE^ORWRP4(X10)
SET ^TMP("ORXS",$JOB,FACU,$SELECT($LENGTH(X10):X10,1:9999999),X6,IFN)=XIFN
End DoDot:2
End DoDot:1
+15 KILL ^TMP("ORXS1",$JOB)
+16 SET FAC=""
SET CNT=-1
+17 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
Begin DoDot:1
+18 SET IFN1=""
+19 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
+20 ; Facility
DO XSET^ORWRP4("1^"_$PIECE(X,"^",2))
+21 ; Allergy Reactant
DO XSET^ORWRP4("2^"_$SELECT(IFN1="ASSESSMENT":"NKA",1:IFN1))
+22 ; Allergy Type
DO XSET^ORWRP4("3^"_$PIECE($PIECE(X,"^",4),"~",2))
+23 IF $LENGTH($PIECE(X,"^",10))
SET X10=$$SETDATE^ORWRP4($PIECE(X,"^",10))
DO XSET^ORWRP4("4^"_$$DATE^ORDVU(X10))
+24 IF '$LENGTH($PIECE(X,"^",10))
DO XSET^ORWRP4("4^"_$PIECE(X,"^",10))
+25 ; Observed/Historical
DO XSET^ORWRP4("5^"_$PIECE($PIECE(X,"^",11),"~",2))
+26 ;Comments
DO COM^ORWRP4(6,$PIECE(X,"^",12))
End DoDot:2
End DoDot:1
+27 KILL ^XTMP(HANDLE,"D")
MERGE ^XTMP(HANDLE,"D")=^TMP("ORXS1",$JOB)
KILL ^TMP("ORXS",$JOB),^TMP("ORXS1",$JOB)
+28 QUIT
