DVBCHS2 ;ALB/JRP - C & P EXTRACT FOR HEALTH SUMMARY (CONT);11-JAN-95
;;2.7;AMIE;;Apr 10, 1995
OUT1(PTR,ARR) ;SET NODE ONE OF OUTPUT
;INPUT : PTR - Pointer to 2507 EXAM file (#396.4)
; ARR - Where to place output (full global reference)
;OUTPUT : None
; See HSCP^DVBCHS0() for format of output array
;NOTES : All input is assumed to exist (no error checking)
;
N CODE,NODE,LOCPTR,LOCATION,OWNPTR,OWNER,OUTPTR
N TYPEPTR,FMDATE,REQPTR,OUTDOM,INVDATE
;DETERMINE CODE (BASED ON TRANSFER OUT/IN DATES)
S NODE=$G(^DVB(396.4,PTR,"TRAN"))
;DONE AT LOCAL FACILITY
S CODE=1
;DONE AT REMOTE FACILITY
S:($P(NODE,"^",1)'="") CODE=2
;DONE AT LOCAL FACILITY FOR REMOTE FACILITY
S:($P(NODE,"^",4)'="") CODE=3
;GET ROUTING LOCATION
S REQPTR=+$P($G(^DVB(396.4,PTR,0)),"^",2)
S LOCPTR=+$P($G(^DVB(396.3,REQPTR,1)),"^",4)
S LOCATION=$P($G(^DG(40.8,LOCPTR,0)),"^",1)
S:('LOCPTR) LOCATION="UNKNOWN"
;DEFAULT REMOTE DOMAINS TO N/A
S OWNER="N/A"
S OUTDOM="N/A"
;EXAM DONE REMOTELY
I (CODE=2) D
.S OUTPTR=+$P($G(^DVB(396.4,PTR,"TRAN")),"^",3)
.S OUTDOM=$P($G(^DIC(4.2,OUTPTR,0)),"^",1)
.S:('OUTPTR) OUTDOM="UNKNOWN"
;EXAM DONE FOR REMOTE FACILITY
I (CODE=3) D
.S OWNPTR=+$P($G(^DVB(396.3,REQPTR,0)),"^",22)
.S OWNER=$P($G(^DIC(4.2,OWNPTR,0)),"^",1)
.S:('OWNPTR) OWNER="UNKNOWN"
;GET EXAM DATE & TYPE
S NODE=$G(^DVB(396.4,PTR,0))
S TYPEPTR=+$P(NODE,"^",3)
S FMDATE=+$P(NODE,"^",6)
;CALCULATE INVERSE EXAM DATE
S INVDATE=9999999-FMDATE
;PUT INFO INTO GLOBAL
S @ARR@(INVDATE,TYPEPTR,1)=LOCATION_"^"_OWNER_"^"_OUTDOM
Q
OUT2(PTR,ARR) ;SET NODE TWO OF OUTPUT
;INPUT : PTR - Pointer to 2507 EXAM file (#396.4)
; ARR - Where to place output (full global reference)
;OUTPUT : None
; See HSCP^DVBCHS0() for format of output array
;NOTES : All input is assumed to exist (no error checking)
;
N NODE,CODE,TYPEPTR,FMDATE,INVDATE
N STATUS,APPRVBY,APPRVDTE,REQPTR
;DETERMINE CODE (BASED ON TRANSFER OUT/IN DATES)
S NODE=$G(^DVB(396.4,PTR,"TRAN"))
;DONE AT LOCAL FACILITY
S CODE=1
;DONE AT REMOTE FACILITY
S:($P(NODE,"^",1)'="") CODE=2
;DONE AT LOCAL FACILITY FOR REMOTE FACILITY
S:($P(NODE,"^",4)'="") CODE=3
;GET INFO FROM REQUEST
S REQPTR=+$P($G(^DVB(396.4,PTR,0)),"^",2)
;GET APPROVAL INFO
S NODE=$G(^DVB(396.3,REQPTR,1))
S APPRVBY=$P(NODE,"^",5)
S APPRVDTE=+$P(NODE,"^",6)
;DETERMINE STATUS
S TMP=$P($G(^DVB(396.3,REQPTR,0)),"^",18)
S STATUS="UNKNOWN"
S:(TMP="N") STATUS="NEW",APPRVBY="N/A"
S:(TMP="P") STATUS="PENDING, REPORTED",APPRVBY="N/A"
S:(TMP="S") STATUS="PENDING SCHEDULED",APPRVBY="N/A"
S:(TMP="R") STATUS="RELEASED TO RO, NOT PRINTED"
S:(TMP="C") STATUS="COMPLETED, PRINTED BY RO"
S:(TMP="X") STATUS="CANCELLED BY MAS",APPRVBY="N/A"
S:(TMP="RX") STATUS="CANCELLED BY RO",APPRVBY="N/A"
S:(TMP="T") STATUS="TRANSCRIBED",APPRVBY="N/A"
S:(TMP="NT") STATUS="NEW, TRANSFERRED IN",APPRVBY="N/A"
S:(TMP="CT") STATUS="COMPLETED, TRANSFERRED OUT"
S:(STATUS="UNKNOWN") APPRVBY="N/A"
;GET EXAM DATE & TYPE
S NODE=$G(^DVB(396.4,PTR,0))
S TYPEPTR=+$P(NODE,"^",3)
S FMDATE=+$P(NODE,"^",6)
;CALCULATE INVERSE EXAM DATE
S INVDATE=9999999-FMDATE
;PUT INFO INTO GLOBAL
S @ARR@(INVDATE,TYPEPTR,2)=STATUS_"^"_APPRVBY_"^"_APPRVDTE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCHS2 3302 printed Sep 23, 2025@19:20:30 Page 2
DVBCHS2 ;ALB/JRP - C & P EXTRACT FOR HEALTH SUMMARY (CONT);11-JAN-95
+1 ;;2.7;AMIE;;Apr 10, 1995
OUT1(PTR,ARR) ;SET NODE ONE OF OUTPUT
+1 ;INPUT : PTR - Pointer to 2507 EXAM file (#396.4)
+2 ; ARR - Where to place output (full global reference)
+3 ;OUTPUT : None
+4 ; See HSCP^DVBCHS0() for format of output array
+5 ;NOTES : All input is assumed to exist (no error checking)
+6 ;
+7 NEW CODE,NODE,LOCPTR,LOCATION,OWNPTR,OWNER,OUTPTR
+8 NEW TYPEPTR,FMDATE,REQPTR,OUTDOM,INVDATE
+9 ;DETERMINE CODE (BASED ON TRANSFER OUT/IN DATES)
+10 SET NODE=$GET(^DVB(396.4,PTR,"TRAN"))
+11 ;DONE AT LOCAL FACILITY
+12 SET CODE=1
+13 ;DONE AT REMOTE FACILITY
+14 if ($PIECE(NODE,"^",1)'="")
SET CODE=2
+15 ;DONE AT LOCAL FACILITY FOR REMOTE FACILITY
+16 if ($PIECE(NODE,"^",4)'="")
SET CODE=3
+17 ;GET ROUTING LOCATION
+18 SET REQPTR=+$PIECE($GET(^DVB(396.4,PTR,0)),"^",2)
+19 SET LOCPTR=+$PIECE($GET(^DVB(396.3,REQPTR,1)),"^",4)
+20 SET LOCATION=$PIECE($GET(^DG(40.8,LOCPTR,0)),"^",1)
+21 if ('LOCPTR)
SET LOCATION="UNKNOWN"
+22 ;DEFAULT REMOTE DOMAINS TO N/A
+23 SET OWNER="N/A"
+24 SET OUTDOM="N/A"
+25 ;EXAM DONE REMOTELY
+26 IF (CODE=2)
Begin DoDot:1
+27 SET OUTPTR=+$PIECE($GET(^DVB(396.4,PTR,"TRAN")),"^",3)
+28 SET OUTDOM=$PIECE($GET(^DIC(4.2,OUTPTR,0)),"^",1)
+29 if ('OUTPTR)
SET OUTDOM="UNKNOWN"
End DoDot:1
+30 ;EXAM DONE FOR REMOTE FACILITY
+31 IF (CODE=3)
Begin DoDot:1
+32 SET OWNPTR=+$PIECE($GET(^DVB(396.3,REQPTR,0)),"^",22)
+33 SET OWNER=$PIECE($GET(^DIC(4.2,OWNPTR,0)),"^",1)
+34 if ('OWNPTR)
SET OWNER="UNKNOWN"
End DoDot:1
+35 ;GET EXAM DATE & TYPE
+36 SET NODE=$GET(^DVB(396.4,PTR,0))
+37 SET TYPEPTR=+$PIECE(NODE,"^",3)
+38 SET FMDATE=+$PIECE(NODE,"^",6)
+39 ;CALCULATE INVERSE EXAM DATE
+40 SET INVDATE=9999999-FMDATE
+41 ;PUT INFO INTO GLOBAL
+42 SET @ARR@(INVDATE,TYPEPTR,1)=LOCATION_"^"_OWNER_"^"_OUTDOM
+43 QUIT
OUT2(PTR,ARR) ;SET NODE TWO OF OUTPUT
+1 ;INPUT : PTR - Pointer to 2507 EXAM file (#396.4)
+2 ; ARR - Where to place output (full global reference)
+3 ;OUTPUT : None
+4 ; See HSCP^DVBCHS0() for format of output array
+5 ;NOTES : All input is assumed to exist (no error checking)
+6 ;
+7 NEW NODE,CODE,TYPEPTR,FMDATE,INVDATE
+8 NEW STATUS,APPRVBY,APPRVDTE,REQPTR
+9 ;DETERMINE CODE (BASED ON TRANSFER OUT/IN DATES)
+10 SET NODE=$GET(^DVB(396.4,PTR,"TRAN"))
+11 ;DONE AT LOCAL FACILITY
+12 SET CODE=1
+13 ;DONE AT REMOTE FACILITY
+14 if ($PIECE(NODE,"^",1)'="")
SET CODE=2
+15 ;DONE AT LOCAL FACILITY FOR REMOTE FACILITY
+16 if ($PIECE(NODE,"^",4)'="")
SET CODE=3
+17 ;GET INFO FROM REQUEST
+18 SET REQPTR=+$PIECE($GET(^DVB(396.4,PTR,0)),"^",2)
+19 ;GET APPROVAL INFO
+20 SET NODE=$GET(^DVB(396.3,REQPTR,1))
+21 SET APPRVBY=$PIECE(NODE,"^",5)
+22 SET APPRVDTE=+$PIECE(NODE,"^",6)
+23 ;DETERMINE STATUS
+24 SET TMP=$PIECE($GET(^DVB(396.3,REQPTR,0)),"^",18)
+25 SET STATUS="UNKNOWN"
+26 if (TMP="N")
SET STATUS="NEW"
SET APPRVBY="N/A"
+27 if (TMP="P")
SET STATUS="PENDING, REPORTED"
SET APPRVBY="N/A"
+28 if (TMP="S")
SET STATUS="PENDING SCHEDULED"
SET APPRVBY="N/A"
+29 if (TMP="R")
SET STATUS="RELEASED TO RO, NOT PRINTED"
+30 if (TMP="C")
SET STATUS="COMPLETED, PRINTED BY RO"
+31 if (TMP="X")
SET STATUS="CANCELLED BY MAS"
SET APPRVBY="N/A"
+32 if (TMP="RX")
SET STATUS="CANCELLED BY RO"
SET APPRVBY="N/A"
+33 if (TMP="T")
SET STATUS="TRANSCRIBED"
SET APPRVBY="N/A"
+34 if (TMP="NT")
SET STATUS="NEW, TRANSFERRED IN"
SET APPRVBY="N/A"
+35 if (TMP="CT")
SET STATUS="COMPLETED, TRANSFERRED OUT"
+36 if (STATUS="UNKNOWN")
SET APPRVBY="N/A"
+37 ;GET EXAM DATE & TYPE
+38 SET NODE=$GET(^DVB(396.4,PTR,0))
+39 SET TYPEPTR=+$PIECE(NODE,"^",3)
+40 SET FMDATE=+$PIECE(NODE,"^",6)
+41 ;CALCULATE INVERSE EXAM DATE
+42 SET INVDATE=9999999-FMDATE
+43 ;PUT INFO INTO GLOBAL
+44 SET @ARR@(INVDATE,TYPEPTR,2)=STATUS_"^"_APPRVBY_"^"_APPRVDTE
+45 QUIT
