VPSRPC10 ;WOIFO/BT - Patient Demographic and Clinic RPC;08/14/14 09:28
;;1.0;VA POINT OF SERVICE (KIOSKS);**4**;Aug 8, 2014;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External Reference DBIA#
; ------------------------
; #1246 - WIN^DGPMDDCF (supported)
; #1713 - LIST^DIC (Supported)
; #10040 - File #44 ^SC( references (Supported)
; #10104 - XLFSTR call (Supported)
QUIT
;
ALLCLN(RESULTS,HLTYPES,DIVIEN,PART,FLAGS,NUMBER,FROM) ;RPC: VPS GET ALL CLINICS
;***** RETURNS THE LIST OF HOSPITAL LOCATIONS
;
; .RESULTS Reference to a local variable where the results
; are returned to.
;
; [HLTYPES] List of location types separated by commas (internal
; values of the TYPE field of the HOSPITAL LOCATION
; file). Only locations of the types defined by this
; parameter are selected by the procedure. By default
; ($G(HLTYPES)=""), all locations are selected.
;
; [DIVIEN] Division IEN. If this parameter is defined and
; greater than zero then only the locations associated
; with this division will be selected.
;
; [PART] The partial match restriction.
;
; [FLAGS] Flags that control the execution (can be combined):
; A Include active locations (default)
; B Backwards. Traverses the index in the opposite
; direction of normal traversal.
; I Include inactive locations
;
; [NUMBER] Maximum number of entries to return. A value of "*"
; or no value in this parameter designates all entries.
;
; [FROM] The index entry(s) from which to begin the list
; ^01: FromName
; ^02: FromIEN
;
; For example, a FROM value of "VA" would list entries
; following VA. You can use the 2-nd and 3-rd "^"-
; pieces of the @RESULTS@(0) node to continue the
; listing in the subsequent procedure calls.
;
; NOTE: The FROM value itself is not included in
; the resulting list.
;
; The ^TMP("DILIST",$J) global node is used by the procedure.
;
; See description of the LIST^DIC for more details about the
; PART, NUMBER and FROM parameters.
;
; Return Values:
; =============
; A negative value of the first "^"-piece of the @RESULTS@(0) indicates an error
; Otherwise, number of hospital locations and the value of the
; FROM parameter for the next procedure call are returned in
; the @RESULTS@(0) and the subsequent nodes of the global array
; contain the locations.
;
; @RESULTS@(0) Error Result Descriptor
; ^01: -1
; ^02: Error Message
;
; @RESULTS@(0) Result Descriptor
; ^01: Number of locations
; ^02: FromName
; ^03: FromIEN
;
; @RESULTS@(i) Hospital Location
; ^01: IEN
; ^02: Name
; ^03: Type (internal)
; ^04: Institution IEN
; ^05: Division IEN
; ^06: Active (0/1)
;
; NOTE: The 6th "^"-piece of the location record (Active) is
; populated only if both "A" and "I" flags are used.
;
S RESULTS=$NA(^TMP("DILIST",$J)) K ^TMP("DILIST",$J)
;
;--- Check the parameters
S HLTYPES=$$UP^XLFSTR($TR($G(HLTYPES)," "))
N HLT,HLTYPE F I=1:1 S HLTYPE=$P(HLTYPES,",",I) QUIT:HLTYPE="" S HLT(HLTYPE)=""
S DIVIEN=$S($G(DIVIEN)>0:+DIVIEN,1:0)
S PART=$G(PART)
S FLAGS=$G(FLAGS)
S NUMBER=$S($G(NUMBER)>0:+NUMBER,1:"*")
;--- If neither "A" nor "I" flag is provided, add the "A" (default)
S:FLAGS="B"!(FLAGS="") FLAGS=FLAGS_"A"
;--- Setup the start point
I $G(FROM)'="" D
. S:$P(FROM,U,2)>0 FROM("IEN")=+$P(FROM,U,2)
. S FROM=$P(FROM,U)
;
;--- Compile the screen logic (be careful with naked references)
N SCR S SCR=""
I $D(HLT)>1 S SCR=SCR_"S D=$P($G(^(0)),U,3) I D'="""",$D(HLT(D)) "
S:DIVIEN SCR=SCR_"I $P($G(^(0)),U,15)=DIVIEN "
S:FLAGS'["A" SCR=SCR_"I '$$ACTLOC^VPSRPC10(+Y) "
S:FLAGS'["I" SCR=SCR_"I $$ACTLOC^VPSRPC10(+Y) "
;
;--- Get the list of locations
N BUF S BUF="@;.01;2I;3I;3.5I"
N ORDER S ORDER="P"_$S(FLAGS["B":"B",1:"")
N VPSERR D LIST^DIC(44,,BUF,ORDER,NUMBER,.FROM,PART,"B",SCR,,,"VPSERR")
I $G(DIERR) K ^TMP("DILIST",$J) S @RESULTS@(0)=-1_U_$$ERROR(.VPSERR) QUIT
;
;--- Populate the Active field if both flags are used
I FLAGS["I",FLAGS["A" D
. N SEQ S SEQ=0
. F S SEQ=$O(@RESULTS@(SEQ)) QUIT:SEQ="" D
. . S $P(@RESULTS@(SEQ,0),U,6)=$$ACTLOC(+@RESULTS@(SEQ,0))
;
;--- Success
N TMP S TMP=$G(^TMP("DILIST",$J,0))
S BUF=+$P(TMP,U)
S:$P(TMP,U,3) $P(BUF,U,2,3)=$G(FROM)_U_$G(FROM("IEN"))
K ^TMP("DILIST",$J,0) S @RESULTS@(0)=BUF
QUIT
;
ACTLOC(LOCIEN) ;***** CHECKS IF THE HOSPITAL LOCATION IS ACTIVE
; LOCIEN : IEN of the hospital location
QUIT:$G(^SC(LOCIEN,"OOS")) 0 ; An OOS entry
;
N D0 S D0=+$G(^SC(LOCIEN,42))
N DGPMOS ; today - used in WIN^DGPMDDCF
N X I D0>0 D WIN^DGPMDDCF QUIT 'X ; Check if ward is inactive
N IADT S IADT=$G(^SC(LOCIEN,"I")) QUIT:'$P(IADT,U) 1 ; No inactivation date
N RDT S RDT=+$P(IADT,U,2) ; reactivate date
I DT>$P(IADT,U) QUIT:'RDT!(DT<RDT) 0 ; Check reactivation date
QUIT 1
;
ERROR(FDAERR) ;return error text
QUIT:'$D(FDAERR) ""
N ERRNUM S ERRNUM=0
S ERRNUM=$O(FDAERR("DIERR",ERRNUM))
N ERRTXT S ERRTXT=""
S:ERRNUM ERRTXT=FDAERR("DIERR",ERRNUM,"TEXT",1)
QUIT ERRTXT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSRPC10 5802 printed Dec 13, 2024@02:43:25 Page 2
VPSRPC10 ;WOIFO/BT - Patient Demographic and Clinic RPC;08/14/14 09:28
+1 ;;1.0;VA POINT OF SERVICE (KIOSKS);**4**;Aug 8, 2014;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External Reference DBIA#
+5 ; ------------------------
+6 ; #1246 - WIN^DGPMDDCF (supported)
+7 ; #1713 - LIST^DIC (Supported)
+8 ; #10040 - File #44 ^SC( references (Supported)
+9 ; #10104 - XLFSTR call (Supported)
+10 QUIT
+11 ;
ALLCLN(RESULTS,HLTYPES,DIVIEN,PART,FLAGS,NUMBER,FROM) ;RPC: VPS GET ALL CLINICS
+1 ;***** RETURNS THE LIST OF HOSPITAL LOCATIONS
+2 ;
+3 ; .RESULTS Reference to a local variable where the results
+4 ; are returned to.
+5 ;
+6 ; [HLTYPES] List of location types separated by commas (internal
+7 ; values of the TYPE field of the HOSPITAL LOCATION
+8 ; file). Only locations of the types defined by this
+9 ; parameter are selected by the procedure. By default
+10 ; ($G(HLTYPES)=""), all locations are selected.
+11 ;
+12 ; [DIVIEN] Division IEN. If this parameter is defined and
+13 ; greater than zero then only the locations associated
+14 ; with this division will be selected.
+15 ;
+16 ; [PART] The partial match restriction.
+17 ;
+18 ; [FLAGS] Flags that control the execution (can be combined):
+19 ; A Include active locations (default)
+20 ; B Backwards. Traverses the index in the opposite
+21 ; direction of normal traversal.
+22 ; I Include inactive locations
+23 ;
+24 ; [NUMBER] Maximum number of entries to return. A value of "*"
+25 ; or no value in this parameter designates all entries.
+26 ;
+27 ; [FROM] The index entry(s) from which to begin the list
+28 ; ^01: FromName
+29 ; ^02: FromIEN
+30 ;
+31 ; For example, a FROM value of "VA" would list entries
+32 ; following VA. You can use the 2-nd and 3-rd "^"-
+33 ; pieces of the @RESULTS@(0) node to continue the
+34 ; listing in the subsequent procedure calls.
+35 ;
+36 ; NOTE: The FROM value itself is not included in
+37 ; the resulting list.
+38 ;
+39 ; The ^TMP("DILIST",$J) global node is used by the procedure.
+40 ;
+41 ; See description of the LIST^DIC for more details about the
+42 ; PART, NUMBER and FROM parameters.
+43 ;
+44 ; Return Values:
+45 ; =============
+46 ; A negative value of the first "^"-piece of the @RESULTS@(0) indicates an error
+47 ; Otherwise, number of hospital locations and the value of the
+48 ; FROM parameter for the next procedure call are returned in
+49 ; the @RESULTS@(0) and the subsequent nodes of the global array
+50 ; contain the locations.
+51 ;
+52 ; @RESULTS@(0) Error Result Descriptor
+53 ; ^01: -1
+54 ; ^02: Error Message
+55 ;
+56 ; @RESULTS@(0) Result Descriptor
+57 ; ^01: Number of locations
+58 ; ^02: FromName
+59 ; ^03: FromIEN
+60 ;
+61 ; @RESULTS@(i) Hospital Location
+62 ; ^01: IEN
+63 ; ^02: Name
+64 ; ^03: Type (internal)
+65 ; ^04: Institution IEN
+66 ; ^05: Division IEN
+67 ; ^06: Active (0/1)
+68 ;
+69 ; NOTE: The 6th "^"-piece of the location record (Active) is
+70 ; populated only if both "A" and "I" flags are used.
+71 ;
+72 SET RESULTS=$NAME(^TMP("DILIST",$JOB))
KILL ^TMP("DILIST",$JOB)
+73 ;
+74 ;--- Check the parameters
+75 SET HLTYPES=$$UP^XLFSTR($TRANSLATE($GET(HLTYPES)," "))
+76 NEW HLT,HLTYPE
FOR I=1:1
SET HLTYPE=$PIECE(HLTYPES,",",I)
if HLTYPE=""
QUIT
SET HLT(HLTYPE)=""
+77 SET DIVIEN=$SELECT($GET(DIVIEN)>0:+DIVIEN,1:0)
+78 SET PART=$GET(PART)
+79 SET FLAGS=$GET(FLAGS)
+80 SET NUMBER=$SELECT($GET(NUMBER)>0:+NUMBER,1:"*")
+81 ;--- If neither "A" nor "I" flag is provided, add the "A" (default)
+82 if FLAGS="B"!(FLAGS="")
SET FLAGS=FLAGS_"A"
+83 ;--- Setup the start point
+84 IF $GET(FROM)'=""
Begin DoDot:1
+85 if $PIECE(FROM,U,2)>0
SET FROM("IEN")=+$PIECE(FROM,U,2)
+86 SET FROM=$PIECE(FROM,U)
End DoDot:1
+87 ;
+88 ;--- Compile the screen logic (be careful with naked references)
+89 NEW SCR
SET SCR=""
+90 IF $DATA(HLT)>1
SET SCR=SCR_"S D=$P($G(^(0)),U,3) I D'="""",$D(HLT(D)) "
+91 if DIVIEN
SET SCR=SCR_"I $P($G(^(0)),U,15)=DIVIEN "
+92 if FLAGS'["A"
SET SCR=SCR_"I '$$ACTLOC^VPSRPC10(+Y) "
+93 if FLAGS'["I"
SET SCR=SCR_"I $$ACTLOC^VPSRPC10(+Y) "
+94 ;
+95 ;--- Get the list of locations
+96 NEW BUF
SET BUF="@;.01;2I;3I;3.5I"
+97 NEW ORDER
SET ORDER="P"_$SELECT(FLAGS["B":"B",1:"")
+98 NEW VPSERR
DO LIST^DIC(44,,BUF,ORDER,NUMBER,.FROM,PART,"B",SCR,,,"VPSERR")
+99 IF $GET(DIERR)
KILL ^TMP("DILIST",$JOB)
SET @RESULTS@(0)=-1_U_$$ERROR(.VPSERR)
QUIT
+100 ;
+101 ;--- Populate the Active field if both flags are used
+102 IF FLAGS["I"
IF FLAGS["A"
Begin DoDot:1
+103 NEW SEQ
SET SEQ=0
+104 FOR
SET SEQ=$ORDER(@RESULTS@(SEQ))
if SEQ=""
QUIT
Begin DoDot:2
+105 SET $PIECE(@RESULTS@(SEQ,0),U,6)=$$ACTLOC(+@RESULTS@(SEQ,0))
End DoDot:2
End DoDot:1
+106 ;
+107 ;--- Success
+108 NEW TMP
SET TMP=$GET(^TMP("DILIST",$JOB,0))
+109 SET BUF=+$PIECE(TMP,U)
+110 if $PIECE(TMP,U,3)
SET $PIECE(BUF,U,2,3)=$GET(FROM)_U_$GET(FROM("IEN"))
+111 KILL ^TMP("DILIST",$JOB,0)
SET @RESULTS@(0)=BUF
+112 QUIT
+113 ;
ACTLOC(LOCIEN) ;***** CHECKS IF THE HOSPITAL LOCATION IS ACTIVE
+1 ; LOCIEN : IEN of the hospital location
+2 ; An OOS entry
if $GET(^SC(LOCIEN,"OOS"))
QUIT 0
+3 ;
+4 NEW D0
SET D0=+$GET(^SC(LOCIEN,42))
+5 ; today - used in WIN^DGPMDDCF
NEW DGPMOS
+6 ; Check if ward is inactive
NEW X
IF D0>0
DO WIN^DGPMDDCF
QUIT 'X
+7 ; No inactivation date
NEW IADT
SET IADT=$GET(^SC(LOCIEN,"I"))
if '$PIECE(IADT,U)
QUIT 1
+8 ; reactivate date
NEW RDT
SET RDT=+$PIECE(IADT,U,2)
+9 ; Check reactivation date
IF DT>$PIECE(IADT,U)
if 'RDT!(DT<RDT)
QUIT 0
+10 QUIT 1
+11 ;
ERROR(FDAERR) ;return error text
+1 if '$DATA(FDAERR)
QUIT ""
+2 NEW ERRNUM
SET ERRNUM=0
+3 SET ERRNUM=$ORDER(FDAERR("DIERR",ERRNUM))
+4 NEW ERRTXT
SET ERRTXT=""
+5 if ERRNUM
SET ERRTXT=FDAERR("DIERR",ERRNUM,"TEXT",1)
+6 QUIT ERRTXT
