DVBCHS1 ;ALB/JRP - C & P EXTRACT FOR HEALTH SUMMARY (CONT);11-JAN-95
;;2.7;AMIE;**149,184**;Apr 10, 1995;Build 10
OUT0(PTR,ARR) ;SET NODE ZERO OF OUTPUT
;INPUT : PTR - Pointer to 2507 EXAM file (#396.4)
; ARR - Where to place output (full global reference)
;OUTPUT : None
; See HSCP() for format of output array
;NOTES : All input is assumed to exist (no error checking)
;
N CODE,FMDATE,TYPE,DOCTOR,PRIORITY
N INVDATE,NODE,REQPTR,TYPEPTR,TMP
;GET ZERO NODE OF 2507 EXAM
S NODE=$G(^DVB(396.4,PTR,0))
;GET INFO OFF OF NODE
S REQPTR=+$P(NODE,"^",2)
S TYPEPTR=+$P(NODE,"^",3)
S FMDATE=+$P(NODE,"^",6)
S DOCTOR=$P(NODE,"^",7)
S:(DOCTOR="") DOCTOR="UNKNOWN"
;GET PRIORITY FROM ZERO NODE OF 2507 REQUEST
S NODE=$G(^DVB(396.3,REQPTR,0))
S TMP=$P(NODE,"^",10)
;CONVERT PRIORITY TO EXTERNAL FORMAT
S PRIORITY="UNKNOWN"
S:(TMP="T") PRIORITY="TERMINAL"
S:(TMP="P") PRIORITY="POW"
S:(TMP="OS") PRIORITY="ORIGINAL SC"
S:(TMP="ON") PRIORITY="ORIGINAL NSC"
S:(TMP="I") PRIORITY="INCREASE"
S:(TMP="R") PRIORITY="REVIEW"
S:(TMP="OTR") PRIORITY="OTHER"
S:(TMP="E") PRIORITY="INSUFFICIENT EXAM"
S:(TMP="AO") PRIORITY="AGENT ORANGE"
S:(TMP="BDD") PRIORITY="BEN DELIV AT DISCHG"
S:(TMP="IDES") PRIORITY="IDES"
S:(TMP="QS") PRIORITY="QUICK START"
;CONVERT EXAM TYPE TO EXTERNAL FORMAT
S TYPE=$P($G(^DVB(396.6,TYPEPTR,0)),"^",1)
S:('TYPEPTR) TYPE="UNKNOWN"
;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
;CALCULATE INVERSE EXAM DATE
S INVDATE=9999999-FMDATE
;PUT INFO INTO GLOBAL
S @ARR@(INVDATE,TYPEPTR,0)=CODE_"^"_FMDATE_"^"_TYPE_"^"_DOCTOR_"^"_PRIORITY
Q
OUTRES(PTR,ARR) ;SET NODE 'RES' 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 LINE,LINES,INVDATE,FMDATE,TYPEPTR,NODE
;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 RESULTS INTO GLOBAL
S LINE=0,LINES=1
F S LINE=+$O(^DVB(396.4,PTR,"RES",LINE)) Q:('LINE) D
.S @ARR@(INVDATE,TYPEPTR,"RES",LINES)=$G(^DVB(396.4,PTR,"RES",LINE,0))
.S LINES=LINES+1
;PUT NUMBER OF LINES INFO INTO GLOBAL
S @ARR@(INVDATE,TYPEPTR,"RES",0)=LINES-1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCHS1 2646 printed Nov 22, 2024@16:54:39 Page 2
DVBCHS1 ;ALB/JRP - C & P EXTRACT FOR HEALTH SUMMARY (CONT);11-JAN-95
+1 ;;2.7;AMIE;**149,184**;Apr 10, 1995;Build 10
OUT0(PTR,ARR) ;SET NODE ZERO 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() for format of output array
+5 ;NOTES : All input is assumed to exist (no error checking)
+6 ;
+7 NEW CODE,FMDATE,TYPE,DOCTOR,PRIORITY
+8 NEW INVDATE,NODE,REQPTR,TYPEPTR,TMP
+9 ;GET ZERO NODE OF 2507 EXAM
+10 SET NODE=$GET(^DVB(396.4,PTR,0))
+11 ;GET INFO OFF OF NODE
+12 SET REQPTR=+$PIECE(NODE,"^",2)
+13 SET TYPEPTR=+$PIECE(NODE,"^",3)
+14 SET FMDATE=+$PIECE(NODE,"^",6)
+15 SET DOCTOR=$PIECE(NODE,"^",7)
+16 if (DOCTOR="")
SET DOCTOR="UNKNOWN"
+17 ;GET PRIORITY FROM ZERO NODE OF 2507 REQUEST
+18 SET NODE=$GET(^DVB(396.3,REQPTR,0))
+19 SET TMP=$PIECE(NODE,"^",10)
+20 ;CONVERT PRIORITY TO EXTERNAL FORMAT
+21 SET PRIORITY="UNKNOWN"
+22 if (TMP="T")
SET PRIORITY="TERMINAL"
+23 if (TMP="P")
SET PRIORITY="POW"
+24 if (TMP="OS")
SET PRIORITY="ORIGINAL SC"
+25 if (TMP="ON")
SET PRIORITY="ORIGINAL NSC"
+26 if (TMP="I")
SET PRIORITY="INCREASE"
+27 if (TMP="R")
SET PRIORITY="REVIEW"
+28 if (TMP="OTR")
SET PRIORITY="OTHER"
+29 if (TMP="E")
SET PRIORITY="INSUFFICIENT EXAM"
+30 if (TMP="AO")
SET PRIORITY="AGENT ORANGE"
+31 if (TMP="BDD")
SET PRIORITY="BEN DELIV AT DISCHG"
+32 if (TMP="IDES")
SET PRIORITY="IDES"
+33 if (TMP="QS")
SET PRIORITY="QUICK START"
+34 ;CONVERT EXAM TYPE TO EXTERNAL FORMAT
+35 SET TYPE=$PIECE($GET(^DVB(396.6,TYPEPTR,0)),"^",1)
+36 if ('TYPEPTR)
SET TYPE="UNKNOWN"
+37 ;DETERMINE CODE (BASED ON TRANSFER OUT/IN DATES)
+38 SET NODE=$GET(^DVB(396.4,PTR,"TRAN"))
+39 ;DONE AT LOCAL FACILITY
+40 SET CODE=1
+41 ;DONE AT REMOTE FACILITY
+42 if ($PIECE(NODE,"^",1)'="")
SET CODE=2
+43 ;DONE AT LOCAL FACILITY FOR REMOTE FACILITY
+44 if ($PIECE(NODE,"^",4)'="")
SET CODE=3
+45 ;CALCULATE INVERSE EXAM DATE
+46 SET INVDATE=9999999-FMDATE
+47 ;PUT INFO INTO GLOBAL
+48 SET @ARR@(INVDATE,TYPEPTR,0)=CODE_"^"_FMDATE_"^"_TYPE_"^"_DOCTOR_"^"_PRIORITY
+49 QUIT
OUTRES(PTR,ARR) ;SET NODE 'RES' 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 LINE,LINES,INVDATE,FMDATE,TYPEPTR,NODE
+8 ;GET EXAM DATE & TYPE
+9 SET NODE=$GET(^DVB(396.4,PTR,0))
+10 SET TYPEPTR=+$PIECE(NODE,"^",3)
+11 SET FMDATE=+$PIECE(NODE,"^",6)
+12 ;CALCULATE INVERSE EXAM DATE
+13 SET INVDATE=9999999-FMDATE
+14 ;PUT RESULTS INTO GLOBAL
+15 SET LINE=0
SET LINES=1
+16 FOR
SET LINE=+$ORDER(^DVB(396.4,PTR,"RES",LINE))
if ('LINE)
QUIT
Begin DoDot:1
+17 SET @ARR@(INVDATE,TYPEPTR,"RES",LINES)=$GET(^DVB(396.4,PTR,"RES",LINE,0))
+18 SET LINES=LINES+1
End DoDot:1
+19 ;PUT NUMBER OF LINES INFO INTO GLOBAL
+20 SET @ARR@(INVDATE,TYPEPTR,"RES",0)=LINES-1
+21 QUIT
