RGADT1 ;HIRMFO/GJC-BUILD ADT MESSAGES (A01/A03) ;09/21/99
;;1.0;CLINICAL INFO RESOURCE NETWORK;**4,14,17,27,28,31,34,45**;30 Apr 99;Build 9
Q ; quit if called from the top
;
EN ; entry point to build/transmit ADT messages
; Messages built by this software are fired off by server protocols:
; RG ADT-A01 SERVER -or- RG ADT-A03 SERVER
;
; This code is called from the RG ADT INPATIENT ENCOUNTER DRIVER &
; RG ADT OUTPATIENT ENCOUNTER DRIVER protocols.
;
; RG ADT OUTPATIENT ENCOUNTER DRIVER is an item protocol under the
; SDAM APPOINTMENTS EVENTS protocol & RG ADT INPATIENT ENCOUNTER DRIVER
; hangs off of the DGPM MOVEMENT EVENTS protocol.
;
; RG ADT OUTPATIENT ENCOUNTER DRIVER hangs off of SDAM APPOINTMENTS
; EVENTS because of DBIA: 1320; RG ADT INPATIENT ENCOUNTER DRIVER
; hangs off of DGPM MOVEMENT EVENTS because of DBIA: 1181.
;
; Integration Agreements (IAs) utilized in this application:
; #1181-subscribers for the DGPM MOVEMENT EVENTS event driver
; #1320-subscribers for the SDAM APPOINTMENT EVENTS event driver
; #2070-check for a national ICN 1st piece, "MPI" node (global read)
; #2161-INIT^HLFNC2
; #2164-GENERATE^HLMA
; #2171-$$WHAT^XUAF4 (Name_"^"_Station Number, we're after Station #)
; #2541-$$KSP^XUPARAM (facility ien, file 4)
; #2624-$$SEND^VAFHUTL()
; #3015-PID segment generation (CIRN PD)
; #3016-EVN segment generation (CIRN PD)
; #3017-PD1 segment generator (CIRN PD)
; #3018-PV1 segment generator (CIRN PD)
; #3072-assign a local ICN to a patient
; #3630-BLDEVN^VAFCQRY, BLDPD1^VAFCQRY & BLDPID^VAFCQRY
; #2988-FILE^VAFCTFU
;
; I $D(RGDG101) then we know we've dropped into this software
; from the DGPM MOVEMENT EVENTS protocol (RG ADT INPATIENT
; ENCOUNTER DRIVER)
;
; Note: DFN is a supported variable in the case of admissions and
; discharges within the Registration package. (part of the discovery
; in the development of RG*1.0*14)
;
; first check if HL7 2.3 messaging has been disabled. DBIA: 2624
I '$P($$SEND^VAFHUTL(),"^",2) Q
S RGOK=0,RGDATE=""
I $D(RGDG101) D
. I $G(DFN)'=+$G(DFN) Q ; DFN must be valid
.; if an national ICN is missing, assign a local then quit
. I '$P($G(^DPT(DFN,"MPI")),"^") S RGLOCAL=$$ICNLC^MPIF001(DFN) Q
. Q:$$IFLOCAL^MPIF001(DFN) ; IA 2701, patient has local icn, quit
. N %,VAERR,VAIP
. S VAIP("D")="LAST" D IN5^VADPT ; dfn should be defined at this point
. S RGTYPE=+$G(VAIP(2)) ; RGTYPE=movement type
. I RGTYPE'=1&(RGTYPE'=3) Q ; admission or discharges only
. S RGENVR=$S(RGTYPE=1:"A1",1:"A2") ; A1=admission, A2=discharge
. S RGDATE=$P($G(VAIP(3)),"^"),RGMOV=$G(VAIP(1))
. ; RGDATE=movement date/time, RGMOV=ien #405
. S:RGDATE]"" RGOK=1
. Q
;
; I $D(RGSD101) then we know we've dropped into this software
; from the SDAM APPOINTMENT EVENTS protocol (RG ADT OUTPATIENT
; ENCOUNTER DRIVER)
;
; Check SDAMEVT for values between five and nine inclusive. See if
; this particular outpatient encounter has a status of CHECKED OUT.
; gjc@Hines OI for patch 14
;
; Note: DFN is not a supported variable in the case of clinic
; appointments and workload crediting for count clinics within the
; Scheduling package. (part of the discovery in the development of
; RG*1.0*14)
;
; check-out, stop code add/edit, disp add/edit?
N I
I $D(RGSD101),($D(SDAMEVT))#2 N DFN D
. ; Note: DFN is unstable; it's up to us to define it...
. ;chk-out, stop code add, stop code change, disp add & disp change
. I SDAMEVT<5!(SDAMEVT>9) Q
. S RGTYPE=SDAMEVT,RGENVR="A3"
. N RGSDOE,RGPARSE,RGPROC,RGTMP S RGPROC=0
. F S RGPROC=$O(^TMP("SDEVT",$J,SDHDL,RGPROC)) Q:'RGPROC D
.. S RGSDOE=0
.. F S RGSDOE=$O(^TMP("SDEVT",$J,SDHDL,RGPROC,"SDOE",RGSDOE)) Q:'RGSDOE D
... S RGSDOE(0)=$G(^TMP("SDEVT",$J,SDHDL,RGPROC,"SDOE",RGSDOE,0,"AFTER"))
... ; Note: RGSDOE(0)=zero node of 409.68, DFN is the second piece
... S DFN=$P(RGSDOE(0),"^",2) Q:'DFN ; DFN must exist
... ; ignore current inpatients
... Q:$L($G(^DPT(DFN,.1))) ; ward location check IA: 10035
...; if an national ICN is missing, assign a local then quit
... I '$P($G(^DPT(DFN,"MPI")),"^") S RGLOCAL=$$ICNLC^MPIF001(DFN) Q
... Q:$$IFLOCAL^MPIF001(DFN) ; IA 2701, patient has local icn, quit
... K RGPARSE D PARSE^SDOE(.RGSDOE,"EXTERNAL","RGPARSE")
... I $G(RGPARSE(.12))="CHECKED OUT" S RGTMP=$P(RGSDOE(0),U)
... S:$G(RGTMP)>RGDATE RGDATE=RGTMP
... Q
.. Q
. S:$G(RGDATE)]"" RGOK=1
. Q
; S ^TMP("RGTRACE",$J)=1
I 'RGOK K RGLOCAL,RGTYPE,RGMOV,RGDATE,RGENVR,RGOK Q ; quit if not A01 or A03
I '($G(DGQUIET)) S:$D(^TMP("RGTRACE",$J)) RGTRACE=1
N RGSITE S RGSITE=+$$SITE^VASITE
;before updating and broadcasting check to see if the date and/or event changed
N LIST,X,OUT,RGCHNG,RGDLT,RGEVN D TFL^VAFCTFU1(.LIST,DFN) S (RGCHNG,OUT,X)=0 F S X=$O(LIST(X)) Q:'X!(OUT=1) D
. S RGDATE=$P(RGDATE,"."),RGDLT=$P(LIST(X),"^",3),RGDLT=$P(RGDLT,"."),RGEVN=$P(LIST(X),"^",4)
. I $P(LIST(X),"^")=$P($$SITE^VASITE,"^",3) S OUT=1 D
.. I RGDATE'=RGDLT D Q
... I RGDATE>RGDLT S RGCHNG=1
.. I RGDATE=RGDLT D
.. I $E(RGENVR,2)'=RGEVN D
... I RGENVR="A3" S RGCHNG=0
... I RGENVR="A1" S RGCHNG=1
... I RGENVR="A2" S RGCHNG=1
;if no change in DLT or Event Reason quit
Q:RGCHNG=0
D FILE^VAFCTFU(DFN,RGSITE_"^"_$G(RGDATE)_"^"_$G(RGENVR),1)
;do FILE^VAFCTFU to update DLT and event reason
I $D(RGTRACE) D EVENT,EXIT Q
N ZTDESC,ZTRTN,ZTSAVE,ZTIO,ZTDTH
S ZTDESC="CIRN HL7 ADT-"_$S(RGTYPE=1:"A01",1:"A03")_" Messaging"
S ZTRTN="EVENT^RGADT1",ZTIO="",ZTDTH=$H
F I="DFN","RGDATE","RGTYPE","RGENVR" S ZTSAVE(I)=""
; check for $D of RGDG101 & RGSD101 need to know protocol executed
S:$D(RGDG101) ZTSAVE("RGDG101")="" S:$D(RGSD101) ZTSAVE("RGSD101")=""
S:$D(RGMOV) ZTSAVE("RGMOV")="" ; defined for admissions & discharges
S:$D(SDOE) ZTSAVE("SDOE")="" ; file ien: 409.68, clinic check out
D ^%ZTLOAD,EXIT
K DGQUIET
Q
;
EVENT ; build the HL7 message
S:$D(ZTQUEUED) ZTREQ="@"
S RGEVT=$S(RGTYPE=1:"A01",1:"A03") K HL
D INIT^HLFNC2("RG ADT-"_RGEVT_" 2.4 SERVER",.HL)
I $G(HL) Q ; error
D BUILD
D GENERATE^HLMA("RG ADT-"_RGEVT_" 2.4 SERVER","LM",1,.RGRSLT,"",.HL)
D KILL^HLTRANS
K HLA("HLS"),RGDATE,RGDG101,RGENVR,RGEVT,RGSD101,RGTYPE
Q
EXIT ; kill and quit
K ^TMP("RGTRACE",$J),RGDATE,RGENVR,RGEVT,RGOK,RGLOCAL,RGMOV,RGPAT
K RGRSLT,RGFSTR,RGTRACE,RGTYPE
Q
BUILD ; build the ADT message
; EVN segment
N CNT,ERR,EVN,RGCNT,SEQ
S RGCNT=1
D BLDEVN^VAFCQRY(DFN,"1,2,4,5,6,7",.EVN,.HL,$G(HL("ETN")))
S HLA("HLS",RGCNT)=$G(EVN(1)) S RGCNT=RGCNT+1
N PID S SEQ="ALL" D BLDPID^VAFCQRY(DFN,1,.SEQ,.PID,.HL,.ERR) S HLA("HLS",RGCNT)=PID(1) S X=1,CNT=1 F S X=$O(PID(X)) Q:'X I $D(PID(X)) S HLA("HLS",RGCNT,CNT)=PID(X),CNT=CNT+1
S RGCNT=RGCNT+1
; PD1 segment
N PD1
S SEQ="3" D BLDPD1^VAFCQRY(DFN,.SEQ,.PD1,.HL,.ERR) S HLA("HLS",RGCNT)=PD1(1)
S RGCNT=RGCNT+1
; PV1 segment
S RGFSTR="2,3,4,5,"_$$COMMANUM(7,45)
;for admission/discharges (registration)
I RGTYPE=1!(RGTYPE=3) S HLA("HLS",4)=$$IN^VAFHLPV1(DFN,RGDATE,RGFSTR,RGMOV,"","")
;for scheduling events: checkout
I RGTYPE'=1&(RGTYPE'=3) S HLA("HLS",4)=$$EN^VAFHLPV1("",,RGFSTR,,HL("Q"),HL("FS"))
S HLA("HLS",4)=$$FAC(HLA("HLS",4))
; adding ZPD segment for POW Status - patch P
S HLA("HLS",5)=$$EN1^VAFHLZPD(DFN,"1,17,21,34") ;**45 changed to EN1 call and added PSEUDO SSN REASON TO ZPD SEGMENT
;**45 added 21 and 1 to ZPD call also
Q
COMMANUM(FROM,TO) ;Build comma seperated list of numbers
;Input : FROM - Starting number (default = 1)
; TO - Ending number (default = FROM)
;Output : Comma separated list of numbers between FROM and TO
; (Ex: 1,2,3)
;Notes : Call assumes FROM <= TO
; copied from COMMANUM^VAFCADT2
;
S FROM=$G(FROM) S:(FROM="") FROM=1
S TO=$G(TO) S:(TO="") TO=FROM
N OUTPUT,X
S OUTPUT=FROM
F X=(FROM+1):1:TO S OUTPUT=(OUTPUT_","_X)
Q OUTPUT
;
FAC(X) ; set facility information, in the form of the Station Number, into
; PV1(3).
; input: the entire PV1 segment
; yield: updated PV1 segment; PV1(3) has facility information (Sta. #)
N Y0,Y1 S Y0=$E(HL("ECH"),$L(HL("ECH")))_$$WHAT^XUAF4(+$$KSP^XUPARAM("INST"),99)
S Y1=$P(X,HL("FS"),4),$P(Y1,$E(HL("ECH")),4)=Y0,$P(X,HL("FS"),4)=Y1
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGADT1 8336 printed Apr 09, 2024@20:47:35 Page 2
RGADT1 ;HIRMFO/GJC-BUILD ADT MESSAGES (A01/A03) ;09/21/99
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**4,14,17,27,28,31,34,45**;30 Apr 99;Build 9
+2 ; quit if called from the top
QUIT
+3 ;
EN ; entry point to build/transmit ADT messages
+1 ; Messages built by this software are fired off by server protocols:
+2 ; RG ADT-A01 SERVER -or- RG ADT-A03 SERVER
+3 ;
+4 ; This code is called from the RG ADT INPATIENT ENCOUNTER DRIVER &
+5 ; RG ADT OUTPATIENT ENCOUNTER DRIVER protocols.
+6 ;
+7 ; RG ADT OUTPATIENT ENCOUNTER DRIVER is an item protocol under the
+8 ; SDAM APPOINTMENTS EVENTS protocol & RG ADT INPATIENT ENCOUNTER DRIVER
+9 ; hangs off of the DGPM MOVEMENT EVENTS protocol.
+10 ;
+11 ; RG ADT OUTPATIENT ENCOUNTER DRIVER hangs off of SDAM APPOINTMENTS
+12 ; EVENTS because of DBIA: 1320; RG ADT INPATIENT ENCOUNTER DRIVER
+13 ; hangs off of DGPM MOVEMENT EVENTS because of DBIA: 1181.
+14 ;
+15 ; Integration Agreements (IAs) utilized in this application:
+16 ; #1181-subscribers for the DGPM MOVEMENT EVENTS event driver
+17 ; #1320-subscribers for the SDAM APPOINTMENT EVENTS event driver
+18 ; #2070-check for a national ICN 1st piece, "MPI" node (global read)
+19 ; #2161-INIT^HLFNC2
+20 ; #2164-GENERATE^HLMA
+21 ; #2171-$$WHAT^XUAF4 (Name_"^"_Station Number, we're after Station #)
+22 ; #2541-$$KSP^XUPARAM (facility ien, file 4)
+23 ; #2624-$$SEND^VAFHUTL()
+24 ; #3015-PID segment generation (CIRN PD)
+25 ; #3016-EVN segment generation (CIRN PD)
+26 ; #3017-PD1 segment generator (CIRN PD)
+27 ; #3018-PV1 segment generator (CIRN PD)
+28 ; #3072-assign a local ICN to a patient
+29 ; #3630-BLDEVN^VAFCQRY, BLDPD1^VAFCQRY & BLDPID^VAFCQRY
+30 ; #2988-FILE^VAFCTFU
+31 ;
+32 ; I $D(RGDG101) then we know we've dropped into this software
+33 ; from the DGPM MOVEMENT EVENTS protocol (RG ADT INPATIENT
+34 ; ENCOUNTER DRIVER)
+35 ;
+36 ; Note: DFN is a supported variable in the case of admissions and
+37 ; discharges within the Registration package. (part of the discovery
+38 ; in the development of RG*1.0*14)
+39 ;
+40 ; first check if HL7 2.3 messaging has been disabled. DBIA: 2624
+41 IF '$PIECE($$SEND^VAFHUTL(),"^",2)
QUIT
+42 SET RGOK=0
SET RGDATE=""
+43 IF $DATA(RGDG101)
Begin DoDot:1
+44 ; DFN must be valid
IF $GET(DFN)'=+$GET(DFN)
QUIT
+45 ; if an national ICN is missing, assign a local then quit
+46 IF '$PIECE($GET(^DPT(DFN,"MPI")),"^")
SET RGLOCAL=$$ICNLC^MPIF001(DFN)
QUIT
+47 ; IA 2701, patient has local icn, quit
if $$IFLOCAL^MPIF001(DFN)
QUIT
+48 NEW %,VAERR,VAIP
+49 ; dfn should be defined at this point
SET VAIP("D")="LAST"
DO IN5^VADPT
+50 ; RGTYPE=movement type
SET RGTYPE=+$GET(VAIP(2))
+51 ; admission or discharges only
IF RGTYPE'=1&(RGTYPE'=3)
QUIT
+52 ; A1=admission, A2=discharge
SET RGENVR=$SELECT(RGTYPE=1:"A1",1:"A2")
+53 SET RGDATE=$PIECE($GET(VAIP(3)),"^")
SET RGMOV=$GET(VAIP(1))
+54 ; RGDATE=movement date/time, RGMOV=ien #405
+55 if RGDATE]""
SET RGOK=1
+56 QUIT
End DoDot:1
+57 ;
+58 ; I $D(RGSD101) then we know we've dropped into this software
+59 ; from the SDAM APPOINTMENT EVENTS protocol (RG ADT OUTPATIENT
+60 ; ENCOUNTER DRIVER)
+61 ;
+62 ; Check SDAMEVT for values between five and nine inclusive. See if
+63 ; this particular outpatient encounter has a status of CHECKED OUT.
+64 ; gjc@Hines OI for patch 14
+65 ;
+66 ; Note: DFN is not a supported variable in the case of clinic
+67 ; appointments and workload crediting for count clinics within the
+68 ; Scheduling package. (part of the discovery in the development of
+69 ; RG*1.0*14)
+70 ;
+71 ; check-out, stop code add/edit, disp add/edit?
+72 NEW I
+73 IF $DATA(RGSD101)
IF ($DATA(SDAMEVT))#2
NEW DFN
Begin DoDot:1
+74 ; Note: DFN is unstable; it's up to us to define it...
+75 ;chk-out, stop code add, stop code change, disp add & disp change
+76 IF SDAMEVT<5!(SDAMEVT>9)
QUIT
+77 SET RGTYPE=SDAMEVT
SET RGENVR="A3"
+78 NEW RGSDOE,RGPARSE,RGPROC,RGTMP
SET RGPROC=0
+79 FOR
SET RGPROC=$ORDER(^TMP("SDEVT",$JOB,SDHDL,RGPROC))
if 'RGPROC
QUIT
Begin DoDot:2
+80 SET RGSDOE=0
+81 FOR
SET RGSDOE=$ORDER(^TMP("SDEVT",$JOB,SDHDL,RGPROC,"SDOE",RGSDOE))
if 'RGSDOE
QUIT
Begin DoDot:3
+82 SET RGSDOE(0)=$GET(^TMP("SDEVT",$JOB,SDHDL,RGPROC,"SDOE",RGSDOE,0,"AFTER"))
+83 ; Note: RGSDOE(0)=zero node of 409.68, DFN is the second piece
+84 ; DFN must exist
SET DFN=$PIECE(RGSDOE(0),"^",2)
if 'DFN
QUIT
+85 ; ignore current inpatients
+86 ; ward location check IA: 10035
if $LENGTH($GET(^DPT(DFN,.1)))
QUIT
+87 ; if an national ICN is missing, assign a local then quit
+88 IF '$PIECE($GET(^DPT(DFN,"MPI")),"^")
SET RGLOCAL=$$ICNLC^MPIF001(DFN)
QUIT
+89 ; IA 2701, patient has local icn, quit
if $$IFLOCAL^MPIF001(DFN)
QUIT
+90 KILL RGPARSE
DO PARSE^SDOE(.RGSDOE,"EXTERNAL","RGPARSE")
+91 IF $GET(RGPARSE(.12))="CHECKED OUT"
SET RGTMP=$PIECE(RGSDOE(0),U)
+92 if $GET(RGTMP)>RGDATE
SET RGDATE=RGTMP
+93 QUIT
End DoDot:3
+94 QUIT
End DoDot:2
+95 if $GET(RGDATE)]""
SET RGOK=1
+96 QUIT
End DoDot:1
+97 ; S ^TMP("RGTRACE",$J)=1
+98 ; quit if not A01 or A03
IF 'RGOK
KILL RGLOCAL,RGTYPE,RGMOV,RGDATE,RGENVR,RGOK
QUIT
+99 IF '($GET(DGQUIET))
if $DATA(^TMP("RGTRACE",$JOB))
SET RGTRACE=1
+100 NEW RGSITE
SET RGSITE=+$$SITE^VASITE
+101 ;before updating and broadcasting check to see if the date and/or event changed
+102 NEW LIST,X,OUT,RGCHNG,RGDLT,RGEVN
DO TFL^VAFCTFU1(.LIST,DFN)
SET (RGCHNG,OUT,X)=0
FOR
SET X=$ORDER(LIST(X))
if 'X!(OUT=1)
QUIT
Begin DoDot:1
+103 SET RGDATE=$PIECE(RGDATE,".")
SET RGDLT=$PIECE(LIST(X),"^",3)
SET RGDLT=$PIECE(RGDLT,".")
SET RGEVN=$PIECE(LIST(X),"^",4)
+104 IF $PIECE(LIST(X),"^")=$PIECE($$SITE^VASITE,"^",3)
SET OUT=1
Begin DoDot:2
+105 IF RGDATE'=RGDLT
Begin DoDot:3
+106 IF RGDATE>RGDLT
SET RGCHNG=1
End DoDot:3
QUIT
+107 IF RGDATE=RGDLT
Begin DoDot:3
End DoDot:3
+108 IF $EXTRACT(RGENVR,2)'=RGEVN
Begin DoDot:3
+109 IF RGENVR="A3"
SET RGCHNG=0
+110 IF RGENVR="A1"
SET RGCHNG=1
+111 IF RGENVR="A2"
SET RGCHNG=1
End DoDot:3
End DoDot:2
End DoDot:1
+112 ;if no change in DLT or Event Reason quit
+113 if RGCHNG=0
QUIT
+114 DO FILE^VAFCTFU(DFN,RGSITE_"^"_$GET(RGDATE)_"^"_$GET(RGENVR),1)
+115 ;do FILE^VAFCTFU to update DLT and event reason
+116 IF $DATA(RGTRACE)
DO EVENT
DO EXIT
QUIT
+117 NEW ZTDESC,ZTRTN,ZTSAVE,ZTIO,ZTDTH
+118 SET ZTDESC="CIRN HL7 ADT-"_$SELECT(RGTYPE=1:"A01",1:"A03")_" Messaging"
+119 SET ZTRTN="EVENT^RGADT1"
SET ZTIO=""
SET ZTDTH=$HOROLOG
+120 FOR I="DFN","RGDATE","RGTYPE","RGENVR"
SET ZTSAVE(I)=""
+121 ; check for $D of RGDG101 & RGSD101 need to know protocol executed
+122 if $DATA(RGDG101)
SET ZTSAVE("RGDG101")=""
if $DATA(RGSD101)
SET ZTSAVE("RGSD101")=""
+123 ; defined for admissions & discharges
if $DATA(RGMOV)
SET ZTSAVE("RGMOV")=""
+124 ; file ien: 409.68, clinic check out
if $DATA(SDOE)
SET ZTSAVE("SDOE")=""
+125 DO ^%ZTLOAD
DO EXIT
+126 KILL DGQUIET
+127 QUIT
+128 ;
EVENT ; build the HL7 message
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 SET RGEVT=$SELECT(RGTYPE=1:"A01",1:"A03")
KILL HL
+3 DO INIT^HLFNC2("RG ADT-"_RGEVT_" 2.4 SERVER",.HL)
+4 ; error
IF $GET(HL)
QUIT
+5 DO BUILD
+6 DO GENERATE^HLMA("RG ADT-"_RGEVT_" 2.4 SERVER","LM",1,.RGRSLT,"",.HL)
+7 DO KILL^HLTRANS
+8 KILL HLA("HLS"),RGDATE,RGDG101,RGENVR,RGEVT,RGSD101,RGTYPE
+9 QUIT
EXIT ; kill and quit
+1 KILL ^TMP("RGTRACE",$JOB),RGDATE,RGENVR,RGEVT,RGOK,RGLOCAL,RGMOV,RGPAT
+2 KILL RGRSLT,RGFSTR,RGTRACE,RGTYPE
+3 QUIT
BUILD ; build the ADT message
+1 ; EVN segment
+2 NEW CNT,ERR,EVN,RGCNT,SEQ
+3 SET RGCNT=1
+4 DO BLDEVN^VAFCQRY(DFN,"1,2,4,5,6,7",.EVN,.HL,$GET(HL("ETN")))
+5 SET HLA("HLS",RGCNT)=$GET(EVN(1))
SET RGCNT=RGCNT+1
+6 NEW PID
SET SEQ="ALL"
DO BLDPID^VAFCQRY(DFN,1,.SEQ,.PID,.HL,.ERR)
SET HLA("HLS",RGCNT)=PID(1)
SET X=1
SET CNT=1
FOR
SET X=$ORDER(PID(X))
if 'X
QUIT
IF $DATA(PID(X))
SET HLA("HLS",RGCNT,CNT)=PID(X)
SET CNT=CNT+1
+7 SET RGCNT=RGCNT+1
+8 ; PD1 segment
+9 NEW PD1
+10 SET SEQ="3"
DO BLDPD1^VAFCQRY(DFN,.SEQ,.PD1,.HL,.ERR)
SET HLA("HLS",RGCNT)=PD1(1)
+11 SET RGCNT=RGCNT+1
+12 ; PV1 segment
+13 SET RGFSTR="2,3,4,5,"_$$COMMANUM(7,45)
+14 ;for admission/discharges (registration)
+15 IF RGTYPE=1!(RGTYPE=3)
SET HLA("HLS",4)=$$IN^VAFHLPV1(DFN,RGDATE,RGFSTR,RGMOV,"","")
+16 ;for scheduling events: checkout
+17 IF RGTYPE'=1&(RGTYPE'=3)
SET HLA("HLS",4)=$$EN^VAFHLPV1("",,RGFSTR,,HL("Q"),HL("FS"))
+18 SET HLA("HLS",4)=$$FAC(HLA("HLS",4))
+19 ; adding ZPD segment for POW Status - patch P
+20 ;**45 changed to EN1 call and added PSEUDO SSN REASON TO ZPD SEGMENT
SET HLA("HLS",5)=$$EN1^VAFHLZPD(DFN,"1,17,21,34")
+21 ;**45 added 21 and 1 to ZPD call also
+22 QUIT
COMMANUM(FROM,TO) ;Build comma seperated list of numbers
+1 ;Input : FROM - Starting number (default = 1)
+2 ; TO - Ending number (default = FROM)
+3 ;Output : Comma separated list of numbers between FROM and TO
+4 ; (Ex: 1,2,3)
+5 ;Notes : Call assumes FROM <= TO
+6 ; copied from COMMANUM^VAFCADT2
+7 ;
+8 SET FROM=$GET(FROM)
if (FROM="")
SET FROM=1
+9 SET TO=$GET(TO)
if (TO="")
SET TO=FROM
+10 NEW OUTPUT,X
+11 SET OUTPUT=FROM
+12 FOR X=(FROM+1):1:TO
SET OUTPUT=(OUTPUT_","_X)
+13 QUIT OUTPUT
+14 ;
FAC(X) ; set facility information, in the form of the Station Number, into
+1 ; PV1(3).
+2 ; input: the entire PV1 segment
+3 ; yield: updated PV1 segment; PV1(3) has facility information (Sta. #)
+4 NEW Y0,Y1
SET Y0=$EXTRACT(HL("ECH"),$LENGTH(HL("ECH")))_$$WHAT^XUAF4(+$$KSP^XUPARAM("INST"),99)
+5 SET Y1=$PIECE(X,HL("FS"),4)
SET $PIECE(Y1,$EXTRACT(HL("ECH")),4)=Y0
SET $PIECE(X,HL("FS"),4)=Y1
+6 QUIT X
