- 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 Mar 13, 2025@21:42:21 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
