- 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 Mar 13, 2025@20:49:08 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
