- VPSRPC1 ;BPOIFO/EL,WOIFO/BT - Patient Demographic and Clinic RPC;08/14/14 09:28
- ;;1.0;VA POINT OF SERVICE (KIOSKS);**1,2,4,14**;Aug 8, 2014;Build 26
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ; External Reference DBIA#
- ; ------------------------
- ; #10035 - ^DPT( references (Supported)
- ; #10040 - ^SC( references (Supported)
- ; #2052 - DID call (Supported)
- ; #2056 - DIQ call (Supported)
- ; #2701 - MPIF001 call (Supported)
- ; #10104 - XLFSTR call (Supported)
- ; #5888 - RPCVIC^DPTLK (Controlled Sub)
- ; #10061 - VADPT call (Supported)
- QUIT
- ;
- GETCLN(VPSARR,CLNAM) ; RPC: VPS GET CLINIC - CLINIC NAME ENTRY
- ; Called by Vetlink Kiosk system.
- ; The RPC will accept 2 parameters. The first parameter represents the
- ; return value as required by RPC Broker, and the 2nd parameter is
- ; single input value representing the name of the clinic (full or partial
- ; name). The output produced will be an array that returns all the
- ; possible matches for the clinic (one to many clinics). Values returned
- ; will be the name of the clinic and the ien of the clinic.
- ;
- ; OUTPUT
- ; VPSARR - passed in by reference; return array of clinics that **contains** input string (CLNAM)
- ; INPUT
- ; CLNAM - partial or full name of clinic;
- ;
- K VPSARR
- I $G(CLNAM)="" S VPSARR(1)="-1^CLINIC NAME NOT SENT" QUIT
- ;
- N VPSCLN,VPSIEN,LOCATION
- N VPSUPNAM S VPSUPNAM=$$UP^XLFSTR(CLNAM)
- N VPSCNAM S VPSCNAM=""
- N VPSFL S VPSFL=44
- ;
- F S VPSCNAM=$O(^SC("B",VPSCNAM)) QUIT:$G(VPSCNAM)="" I VPSCNAM[VPSUPNAM D
- . S VPSCLN=""
- . F S VPSCLN=$O(^SC("B",VPSCNAM,VPSCLN)) QUIT:$G(VPSCLN)="" D
- . . S VPSIEN=VPSCLN
- . . D SET(.VPSARR,VPSFL,VPSIEN,".001",VPSCLN,"CLINIC NUMBER") ;Clinic IEN
- . . D SET(.VPSARR,VPSFL,VPSIEN,".01",VPSCNAM) ;Clinic Name
- . . S LOCATION=$$GET1^DIQ(VPSFL,VPSCLN_",",10,"E") ;Physical Location
- . . D SET(.VPSARR,VPSFL,VPSIEN,10,LOCATION)
- ;
- I '$D(VPSARR) S VPSARR(1)="-1^CLINIC COULD NOT BE FOUND." QUIT
- ;
- QUIT
- ;
- GETDATA(VPSARR,SSN) ; RPC: VPS GET PATIENT DEMOGRAPHIC
- ; This RPC is called by the Vetlink Kiosk (point of service) system.
- ; Given Patient SSN, this RPC returns the patient demographics,insurance,and up-coming appointments, etc.
- ;
- ; INPUT
- ; SSN - patient SSN
- ; OUTPUT
- ; VPSARR - passed in by reference; return array of patient demographics
- ;
- D GETDATA2(.VPSARR,$G(SSN),"SSN")
- QUIT
- ;
- GETDATA2(VPSARR,VPSNUM,VPSTYP) ; RPC: VPS GET2 PATIENT DEMOGRAPHIC
- ; This RPC is called by the Vetlink Kiosk (point of service) system.
- ; Given Patient SSN or DFN or ICN or VIC/CAC, this RPC returns the patient demographics,insurance,and up-coming appointments, etc.
- ;
- ; OUTPUT
- ; VPSARR - passed in by reference; return array of patient demographics,appts
- ; INPUT
- ; VPSNUM - Parameter Value - patient SSN OR DFN OR ICN OR VIC/CAC (REQUIRED)
- ; VPSTYP - Parameter TYPE - SSN or DFN OR ICN OR VIC/CAC (REQUIRED)
- ;
- ; Return all categories
- N CATEGORY,ICAT ;F ICAT=1:1:6 S CATEGORY(ICAT)=ICAT
- N ANS
- D DT^DILF("E","T-60",.ANS)
- S CATEGORY(1)=1_";"_ANS_":"
- S CATEGORY(2)=6
- D GETDATA3(.VPSARR,$G(VPSNUM),$G(VPSTYP),.CATEGORY) ; RPC: VPS GET2 PATIENT DEMOGRAPHIC
- QUIT
- ;
- GETDATA3(VPSARR,VPSNUM,VPSTYP,VPSCAT) ; RPC: VPS ENHANCED GET PATIENT DEMOGRAPHIC
- ; This RPC is called by the Vetlink Kiosk (point of service) system.
- ; Given Patient SSN or DFN or ICN or VIC/CAC, this RPC returns the patient demographics,insurance,and up-coming appointments, etc
- ; for selected categories
- ;
- ; OUTPUT
- ; VPSARR - passed in by reference; return array of patient demographics,appts
- ; INPUT
- ; VPSNUM - Parameter Value - patient SSN OR DFN OR ICN OR VIC/CAC (REQUIRED)
- ; VPSTYP - Parameter TYPE - SSN or DFN OR ICN OR VIC/CAC (REQUIRED)
- ; VPSCAT - List of Category to print (REQUIRED)
- ; VPSCAT(1..N)=CATEGORY;FROMDATE:THROUGHDATE
- ; Example input parameter :
- ; VPSCAT(1)=6 - Patient demographics
- ; VPSCAT(2)=1;3140101:3141231 - Appointments start from 1/1/2014 through 12/31/2014
- ; VPSCAT(3)=2;3140601:3140630 - Lab Orders start from 6/1/2014 through 6/30/2014
- ; Valid Category:
- ; 1 - Appointment (With Date Range option)
- ; 2 - Lab Orders (With Date Range option)
- ; 3 - Consults
- ; 4 - Radiology (With Date Range option)
- ; 5 - Problem
- ; 6 - Patient Characteristics
- ; - Patient Current Inpatient Status
- ; - Patient Ward Location
- ; - Patient Bed Assignment
- ; - Facility Directory Preference
- ; 7 - Patient Additional patient demographic data
- ; 8 - Patient Clinical (Health Factor)
- ;
- ;
- K VPSARR
- S VPSARR(1)=$$VALIDATE($G(VPSTYP),$G(VPSNUM))
- QUIT:+VPSARR(1)=-1
- ;
- N DFN S DFN=VPSARR(1)
- K VPSARR
- N CAT,DTRANGE,SEQ S SEQ=0
- ;
- F S SEQ=$O(VPSCAT(SEQ)) QUIT:'SEQ D
- . S CAT=$P(VPSCAT(SEQ),";")
- . S DTRANGE=$P(VPSCAT(SEQ),";",2)
- . I CAT=1,$P(DTRANGE,":")="" D
- .. N ANS
- .. D DT^DILF("E","T-60",.ANS)
- .. S DTRANGE=ANS_":"_$P(DTRANGE,":",2)
- . I CAT=1 D GETAPPT^VPSRPC11(.VPSARR,DFN,DTRANGE) ;Appointments
- . I CAT=2 D GETLAB^VPSRPC12(.VPSARR,DFN,DTRANGE) ;Lab Orders
- . I CAT=3 D GETCNSLT^VPSRPC13(.VPSARR,DFN,DTRANGE) ;Consult
- . I CAT=4 D GETRAD^VPSRPC14(.VPSARR,DFN,DTRANGE) ;Radiology
- . I CAT=5 D GETPRBLM^VPSRPC15(.VPSARR,DFN) ;Problem
- . I CAT=6 D GETDEM^VPSRPC16(.VPSARR,DFN) ;Demographics
- . I CAT=7 D GETADEM^VPSRPC15(.VPSARR,DFN) ; Additional demographic data
- . I CAT=8 D GETHF^VPSRPC15(.VPSARR,DFN) ; Patient Health Factor
- QUIT
- ;
- VALIDATE(VPSTYP,VPSNUM) ;validate patient-id type and patient id value
- ; INPUT
- ; VPSTYP - Parameter TYPE - SSN or DFN OR ICN OR VIC/CAC (REQUIRED)
- ; VPSNUM - Parameter Value - patient SSN OR DFN OR ICN OR VIC/CAC (REQUIRED)
- ; RETURN
- ; DFN if patient-type/id pair is valid otherwise return -1^Errormessage
- ;
- N CM S CM=","
- ;
- QUIT:$G(VPSTYP)="" "-1^TYPE IS REQUIRED (VALID TYPE: SSN, DFN, ICN OR VIC/CAC)"
- QUIT:'$F(",SSN,DFN,ICN,VIC/CAC,",CM_VPSTYP_CM) "-1^INVALID TYPE (VALID TYPE: SSN, DFN, ICN OR VIC/CAC)"
- QUIT:$G(VPSNUM)="" "-1^"_VPSTYP_" IS REQUIRED"
- ;
- N DFN S DFN=0
- ;
- I VPSTYP="SSN" D
- . N SSN S SSN=$TR(VPSNUM,"- ")
- . I SSN'?1.N S DFN="-1"_U_"SSN SHOULD BE NUMERIC: "_VPSNUM QUIT
- . S DFN=$O(^DPT("SSN",SSN,0))
- . I +DFN'>0 S DFN="-1"_U_"NO PATIENT FOUND WITH SSN: "_VPSNUM
- QUIT:DFN DFN
- ;
- I VPSTYP="DFN" D
- . S DFN=VPSNUM
- . I '$D(^DPT(DFN)) S DFN="-1"_U_"NO PATIENT FOUND WITH DFN: "_DFN
- QUIT:DFN DFN
- ;
- I VPSTYP="VIC/CAC" D
- . D RPCVIC^DPTLK(.DFN,VPSNUM) ; get DFN given VIC/CAC number - IA 5888
- . S:DFN=-1 DFN="-1^INVALID VIC/CAC NUMBER "_VPSNUM
- QUIT:DFN DFN
- ;
- I VPSTYP="ICN" D
- . S DFN=$$GETDFN^MPIF001(VPSNUM) ; get DFN given ICN in the Patient file - IA 2701
- ;
- QUIT DFN
- ;
- SET(VPSARR,VPSFL,VPSIEN,VPSFLD,VPSDA,VPSDS,VPSCAT) ;Set line item to output array
- ; OUTPUT
- ; VPSARR - passed in by reference; This is the Array of clinics contains the line item
- ; INPUT
- ; VPSFL - File Number
- ; VPSIEN - File IEN
- ; VPSFLD - File Field Number
- ; VPSDA - Field Value
- ; VPSDS - (optional) User defined Field Name - default is the Fileman fieldname
- ; VPSCAT - Category: 1 - Appointment, 2 - Lab Orders, 3 - Consults, 4 - Radiology, 5 - Problem, 6 - Patient demographics
- ;
- N CNT S CNT=$O(VPSARR(""),-1)+1
- I $G(VPSDS)="",$G(VPSFL),$G(VPSFLD) N VPSOUT D FIELD^DID(VPSFL,VPSFLD,"","LABEL","VPSOUT") S VPSDS=VPSOUT("LABEL")
- S VPSARR(CNT)=$G(VPSFL)_U_$G(VPSIEN)_U_$G(VPSFLD)_U_$G(VPSDA)_U_$G(VPSDS)_U_$G(VPSCAT)
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSRPC1 7918 printed Jan 18, 2025@03:44:31 Page 2
- VPSRPC1 ;BPOIFO/EL,WOIFO/BT - Patient Demographic and Clinic RPC;08/14/14 09:28
- +1 ;;1.0;VA POINT OF SERVICE (KIOSKS);**1,2,4,14**;Aug 8, 2014;Build 26
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ; External Reference DBIA#
- +5 ; ------------------------
- +6 ; #10035 - ^DPT( references (Supported)
- +7 ; #10040 - ^SC( references (Supported)
- +8 ; #2052 - DID call (Supported)
- +9 ; #2056 - DIQ call (Supported)
- +10 ; #2701 - MPIF001 call (Supported)
- +11 ; #10104 - XLFSTR call (Supported)
- +12 ; #5888 - RPCVIC^DPTLK (Controlled Sub)
- +13 ; #10061 - VADPT call (Supported)
- +14 QUIT
- +15 ;
- GETCLN(VPSARR,CLNAM) ; RPC: VPS GET CLINIC - CLINIC NAME ENTRY
- +1 ; Called by Vetlink Kiosk system.
- +2 ; The RPC will accept 2 parameters. The first parameter represents the
- +3 ; return value as required by RPC Broker, and the 2nd parameter is
- +4 ; single input value representing the name of the clinic (full or partial
- +5 ; name). The output produced will be an array that returns all the
- +6 ; possible matches for the clinic (one to many clinics). Values returned
- +7 ; will be the name of the clinic and the ien of the clinic.
- +8 ;
- +9 ; OUTPUT
- +10 ; VPSARR - passed in by reference; return array of clinics that **contains** input string (CLNAM)
- +11 ; INPUT
- +12 ; CLNAM - partial or full name of clinic;
- +13 ;
- +14 KILL VPSARR
- +15 IF $GET(CLNAM)=""
- SET VPSARR(1)="-1^CLINIC NAME NOT SENT"
- QUIT
- +16 ;
- +17 NEW VPSCLN,VPSIEN,LOCATION
- +18 NEW VPSUPNAM
- SET VPSUPNAM=$$UP^XLFSTR(CLNAM)
- +19 NEW VPSCNAM
- SET VPSCNAM=""
- +20 NEW VPSFL
- SET VPSFL=44
- +21 ;
- +22 FOR
- SET VPSCNAM=$ORDER(^SC("B",VPSCNAM))
- if $GET(VPSCNAM)=""
- QUIT
- IF VPSCNAM[VPSUPNAM
- Begin DoDot:1
- +23 SET VPSCLN=""
- +24 FOR
- SET VPSCLN=$ORDER(^SC("B",VPSCNAM,VPSCLN))
- if $GET(VPSCLN)=""
- QUIT
- Begin DoDot:2
- +25 SET VPSIEN=VPSCLN
- +26 ;Clinic IEN
- DO SET(.VPSARR,VPSFL,VPSIEN,".001",VPSCLN,"CLINIC NUMBER")
- +27 ;Clinic Name
- DO SET(.VPSARR,VPSFL,VPSIEN,".01",VPSCNAM)
- +28 ;Physical Location
- SET LOCATION=$$GET1^DIQ(VPSFL,VPSCLN_",",10,"E")
- +29 DO SET(.VPSARR,VPSFL,VPSIEN,10,LOCATION)
- End DoDot:2
- End DoDot:1
- +30 ;
- +31 IF '$DATA(VPSARR)
- SET VPSARR(1)="-1^CLINIC COULD NOT BE FOUND."
- QUIT
- +32 ;
- +33 QUIT
- +34 ;
- GETDATA(VPSARR,SSN) ; RPC: VPS GET PATIENT DEMOGRAPHIC
- +1 ; This RPC is called by the Vetlink Kiosk (point of service) system.
- +2 ; Given Patient SSN, this RPC returns the patient demographics,insurance,and up-coming appointments, etc.
- +3 ;
- +4 ; INPUT
- +5 ; SSN - patient SSN
- +6 ; OUTPUT
- +7 ; VPSARR - passed in by reference; return array of patient demographics
- +8 ;
- +9 DO GETDATA2(.VPSARR,$GET(SSN),"SSN")
- +10 QUIT
- +11 ;
- GETDATA2(VPSARR,VPSNUM,VPSTYP) ; RPC: VPS GET2 PATIENT DEMOGRAPHIC
- +1 ; This RPC is called by the Vetlink Kiosk (point of service) system.
- +2 ; Given Patient SSN or DFN or ICN or VIC/CAC, this RPC returns the patient demographics,insurance,and up-coming appointments, etc.
- +3 ;
- +4 ; OUTPUT
- +5 ; VPSARR - passed in by reference; return array of patient demographics,appts
- +6 ; INPUT
- +7 ; VPSNUM - Parameter Value - patient SSN OR DFN OR ICN OR VIC/CAC (REQUIRED)
- +8 ; VPSTYP - Parameter TYPE - SSN or DFN OR ICN OR VIC/CAC (REQUIRED)
- +9 ;
- +10 ; Return all categories
- +11 ;F ICAT=1:1:6 S CATEGORY(ICAT)=ICAT
- NEW CATEGORY,ICAT
- +12 NEW ANS
- +13 DO DT^DILF("E","T-60",.ANS)
- +14 SET CATEGORY(1)=1_";"_ANS_":"
- +15 SET CATEGORY(2)=6
- +16 ; RPC: VPS GET2 PATIENT DEMOGRAPHIC
- DO GETDATA3(.VPSARR,$GET(VPSNUM),$GET(VPSTYP),.CATEGORY)
- +17 QUIT
- +18 ;
- GETDATA3(VPSARR,VPSNUM,VPSTYP,VPSCAT) ; RPC: VPS ENHANCED GET PATIENT DEMOGRAPHIC
- +1 ; This RPC is called by the Vetlink Kiosk (point of service) system.
- +2 ; Given Patient SSN or DFN or ICN or VIC/CAC, this RPC returns the patient demographics,insurance,and up-coming appointments, etc
- +3 ; for selected categories
- +4 ;
- +5 ; OUTPUT
- +6 ; VPSARR - passed in by reference; return array of patient demographics,appts
- +7 ; INPUT
- +8 ; VPSNUM - Parameter Value - patient SSN OR DFN OR ICN OR VIC/CAC (REQUIRED)
- +9 ; VPSTYP - Parameter TYPE - SSN or DFN OR ICN OR VIC/CAC (REQUIRED)
- +10 ; VPSCAT - List of Category to print (REQUIRED)
- +11 ; VPSCAT(1..N)=CATEGORY;FROMDATE:THROUGHDATE
- +12 ; Example input parameter :
- +13 ; VPSCAT(1)=6 - Patient demographics
- +14 ; VPSCAT(2)=1;3140101:3141231 - Appointments start from 1/1/2014 through 12/31/2014
- +15 ; VPSCAT(3)=2;3140601:3140630 - Lab Orders start from 6/1/2014 through 6/30/2014
- +16 ; Valid Category:
- +17 ; 1 - Appointment (With Date Range option)
- +18 ; 2 - Lab Orders (With Date Range option)
- +19 ; 3 - Consults
- +20 ; 4 - Radiology (With Date Range option)
- +21 ; 5 - Problem
- +22 ; 6 - Patient Characteristics
- +23 ; - Patient Current Inpatient Status
- +24 ; - Patient Ward Location
- +25 ; - Patient Bed Assignment
- +26 ; - Facility Directory Preference
- +27 ; 7 - Patient Additional patient demographic data
- +28 ; 8 - Patient Clinical (Health Factor)
- +29 ;
- +30 ;
- +31 KILL VPSARR
- +32 SET VPSARR(1)=$$VALIDATE($GET(VPSTYP),$GET(VPSNUM))
- +33 if +VPSARR(1)=-1
- QUIT
- +34 ;
- +35 NEW DFN
- SET DFN=VPSARR(1)
- +36 KILL VPSARR
- +37 NEW CAT,DTRANGE,SEQ
- SET SEQ=0
- +38 ;
- +39 FOR
- SET SEQ=$ORDER(VPSCAT(SEQ))
- if 'SEQ
- QUIT
- Begin DoDot:1
- +40 SET CAT=$PIECE(VPSCAT(SEQ),";")
- +41 SET DTRANGE=$PIECE(VPSCAT(SEQ),";",2)
- +42 IF CAT=1
- IF $PIECE(DTRANGE,":")=""
- Begin DoDot:2
- +43 NEW ANS
- +44 DO DT^DILF("E","T-60",.ANS)
- +45 SET DTRANGE=ANS_":"_$PIECE(DTRANGE,":",2)
- End DoDot:2
- +46 ;Appointments
- IF CAT=1
- DO GETAPPT^VPSRPC11(.VPSARR,DFN,DTRANGE)
- +47 ;Lab Orders
- IF CAT=2
- DO GETLAB^VPSRPC12(.VPSARR,DFN,DTRANGE)
- +48 ;Consult
- IF CAT=3
- DO GETCNSLT^VPSRPC13(.VPSARR,DFN,DTRANGE)
- +49 ;Radiology
- IF CAT=4
- DO GETRAD^VPSRPC14(.VPSARR,DFN,DTRANGE)
- +50 ;Problem
- IF CAT=5
- DO GETPRBLM^VPSRPC15(.VPSARR,DFN)
- +51 ;Demographics
- IF CAT=6
- DO GETDEM^VPSRPC16(.VPSARR,DFN)
- +52 ; Additional demographic data
- IF CAT=7
- DO GETADEM^VPSRPC15(.VPSARR,DFN)
- +53 ; Patient Health Factor
- IF CAT=8
- DO GETHF^VPSRPC15(.VPSARR,DFN)
- End DoDot:1
- +54 QUIT
- +55 ;
- VALIDATE(VPSTYP,VPSNUM) ;validate patient-id type and patient id value
- +1 ; INPUT
- +2 ; VPSTYP - Parameter TYPE - SSN or DFN OR ICN OR VIC/CAC (REQUIRED)
- +3 ; VPSNUM - Parameter Value - patient SSN OR DFN OR ICN OR VIC/CAC (REQUIRED)
- +4 ; RETURN
- +5 ; DFN if patient-type/id pair is valid otherwise return -1^Errormessage
- +6 ;
- +7 NEW CM
- SET CM=","
- +8 ;
- +9 if $GET(VPSTYP)=""
- QUIT "-1^TYPE IS REQUIRED (VALID TYPE: SSN, DFN, ICN OR VIC/CAC)"
- +10 if '$FIND(",SSN,DFN,ICN,VIC/CAC,",CM_VPSTYP_CM)
- QUIT "-1^INVALID TYPE (VALID TYPE: SSN, DFN, ICN OR VIC/CAC)"
- +11 if $GET(VPSNUM)=""
- QUIT "-1^"_VPSTYP_" IS REQUIRED"
- +12 ;
- +13 NEW DFN
- SET DFN=0
- +14 ;
- +15 IF VPSTYP="SSN"
- Begin DoDot:1
- +16 NEW SSN
- SET SSN=$TRANSLATE(VPSNUM,"- ")
- +17 IF SSN'?1.N
- SET DFN="-1"_U_"SSN SHOULD BE NUMERIC: "_VPSNUM
- QUIT
- +18 SET DFN=$ORDER(^DPT("SSN",SSN,0))
- +19 IF +DFN'>0
- SET DFN="-1"_U_"NO PATIENT FOUND WITH SSN: "_VPSNUM
- End DoDot:1
- +20 if DFN
- QUIT DFN
- +21 ;
- +22 IF VPSTYP="DFN"
- Begin DoDot:1
- +23 SET DFN=VPSNUM
- +24 IF '$DATA(^DPT(DFN))
- SET DFN="-1"_U_"NO PATIENT FOUND WITH DFN: "_DFN
- End DoDot:1
- +25 if DFN
- QUIT DFN
- +26 ;
- +27 IF VPSTYP="VIC/CAC"
- Begin DoDot:1
- +28 ; get DFN given VIC/CAC number - IA 5888
- DO RPCVIC^DPTLK(.DFN,VPSNUM)
- +29 if DFN=-1
- SET DFN="-1^INVALID VIC/CAC NUMBER "_VPSNUM
- End DoDot:1
- +30 if DFN
- QUIT DFN
- +31 ;
- +32 IF VPSTYP="ICN"
- Begin DoDot:1
- +33 ; get DFN given ICN in the Patient file - IA 2701
- SET DFN=$$GETDFN^MPIF001(VPSNUM)
- End DoDot:1
- +34 ;
- +35 QUIT DFN
- +36 ;
- SET(VPSARR,VPSFL,VPSIEN,VPSFLD,VPSDA,VPSDS,VPSCAT) ;Set line item to output array
- +1 ; OUTPUT
- +2 ; VPSARR - passed in by reference; This is the Array of clinics contains the line item
- +3 ; INPUT
- +4 ; VPSFL - File Number
- +5 ; VPSIEN - File IEN
- +6 ; VPSFLD - File Field Number
- +7 ; VPSDA - Field Value
- +8 ; VPSDS - (optional) User defined Field Name - default is the Fileman fieldname
- +9 ; VPSCAT - Category: 1 - Appointment, 2 - Lab Orders, 3 - Consults, 4 - Radiology, 5 - Problem, 6 - Patient demographics
- +10 ;
- +11 NEW CNT
- SET CNT=$ORDER(VPSARR(""),-1)+1
- +12 IF $GET(VPSDS)=""
- IF $GET(VPSFL)
- IF $GET(VPSFLD)
- NEW VPSOUT
- DO FIELD^DID(VPSFL,VPSFLD,"","LABEL","VPSOUT")
- SET VPSDS=VPSOUT("LABEL")
- +13 SET VPSARR(CNT)=$GET(VPSFL)_U_$GET(VPSIEN)_U_$GET(VPSFLD)_U_$GET(VPSDA)_U_$GET(VPSDS)_U_$GET(VPSCAT)
- +14 QUIT