Routine: DVBCHS2

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

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCHS2   3302     printed  Apr 23, 2025@17:58:56                                                                                                                                                                                                     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

DVBCHS2.m