RORRP015 ;HCIOFO/SG - RPC: DIVISIONS AND HOSPITAL LOCATIONS ; 5/25/11 11:49am
;;1.5;CLINICAL CASE REGISTRIES;**1,15**;Feb 17, 2006;Build 27
;
; This routine uses the following IAs:
;
; #1246 WIN^DGPMDDCF (supported)
; #417 Access to the file #40.8 (controlled)
; #10040 Access to the HOSPITAL LOCATION file (supported)
;
Q
;
;***** CHECKS IF THE HOSPITAL LOCATION IS ACTIVE
;
; LOCIEN IEN of the hospital location
;
ACTLOC(LOCIEN) ;
N D0,DGPMOS,RDT,X
Q:$G(^SC(LOCIEN,"OOS")) 0 ; An OOS entry
S D0=+$G(^SC(LOCIEN,42))
I D0>0 D WIN^DGPMDDCF Q 'X ; Check if ward is inactive
S X=$G(^SC(LOCIEN,"I")) Q:'$P(X,U) 1 ; No inactivation date
S RDT=+$P(X,U,2)
I DT>$P(X,U) Q:'RDT!(DT<RDT) 0 ; Check reactivation date
Q 1
;
;***** RETURNS THE LIST OF DIVISIONS
; RPC: [ROR LIST DIVISIONS]
;
; .RESULTS Reference to a local variable where the results
; are returned to.
;
; [PART] The partial match restriction.
;
; [FLAGS] Flags that control the execution (can be combined)
; B Backwards. Traverses the index in the opposite
; direction of normal traversal.
;
; [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 (see the RPCSTK^RORERR procedure for more
; details).
;
; Otherwise, number of divisions 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 divisions.
;
; @RESULTS@(0) Result Descriptor
; ^01: Number of divisions
; ^02: FromName
; ^03: FromIEN
;
; @RESULTS@(i) Division
; ^01: IEN
; ^02: Name
; ^03: Facility Number
; ^04: Institution IEN
;
DIVLIST(RESULTS,PART,FLAGS,NUMBER,FROM) ;
N BUF,RC,RORERRDL,RORMSG,TMP,DIERR
D CLEAR^RORERR("DIVLIST^RORRP015",1)
K RESULTS S RESULTS=$NA(^TMP("DILIST",$J)) K @RESULTS
;--- Check the parameters
S PART=$G(PART),FLAGS=$G(FLAGS)
I PART="??" S PART="" ;user selects All Divisions
S NUMBER=$S($G(NUMBER)>0:+NUMBER,1:"*")
;--- Setup the start point
I $G(FROM)'="" D S FROM=$P(FROM,U)
. S:$P(FROM,U,2)>0 FROM("IEN")=+$P(FROM,U,2)
;--- Get the list of divisions
S BUF="@;.01;1;.07I",TMP="P"_$S(FLAGS["B":"B",1:"")
D LIST^DIC(40.8,,BUF,TMP,NUMBER,.FROM,PART,"B",,,,"RORMSG")
I $G(DIERR) D D RPCSTK^RORERR(.RESULTS,RC) Q
. S RC=$$DBS^RORERR("RORMSG",-9,,,40.8)
. K ^TMP("DILIST",$J)
;--- Success
S TMP=$G(^TMP("DILIST",$J,0)),BUF=+$P(TMP,U)
K ^TMP("DILIST",$J,0)
S:$P(TMP,U,3) $P(BUF,U,2,3)=$G(FROM)_U_$G(FROM("IEN"))
S @RESULTS@(0)=BUF
Q
;
;***** RETURNS THE LIST OF HOSPITAL LOCATIONS
; RPC: [ROR LIST 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 (see the RPCSTK^RORERR procedure for more
; details).
;
; 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) 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.
;
HLOCLIST(RESULTS,HLTYPES,DIVIEN,PART,FLAGS,NUMBER,FROM) ;
N BUF,I,RC,RORERRDL,RORHLT,RORMSG,SCR,TMP
D CLEAR^RORERR("HLOCLIST^RORRP015",1)
K RESULTS S RESULTS=$NA(^TMP("DILIST",$J)) K @RESULTS
;--- Check the parameters
S HLTYPES=$$UP^XLFSTR($TR($G(HLTYPES)," "))
F I=1:1 S TMP=$P(HLTYPES,",",I) Q:TMP="" S RORHLT(TMP)=""
S DIVIEN=$S($G(DIVIEN)>0:+DIVIEN,1:0)
S PART=$G(PART),FLAGS=$G(FLAGS)
S NUMBER=$S($G(NUMBER)>0:+NUMBER,1:"*")
;--- If neither "A" nor "I" flag is provided, add the "A" (default)
S:$TR(FLAGS,"AI")=FLAGS FLAGS=FLAGS_"A"
;--- Setup the start point
I $G(FROM)'="" D S FROM=$P(FROM,U)
. S:$P(FROM,U,2)>0 FROM("IEN")=+$P(FROM,U,2)
;--- Compile the screen logic (be careful with naked references)
S SCR=""
D:$D(RORHLT)>1
. S SCR=SCR_"S D=$P($G(^(0)),U,3) I D'="""",$D(RORHLT(D)) "
S:DIVIEN SCR=SCR_"I $P($G(^(0)),U,15)=DIVIEN "
S:FLAGS'["A" SCR=SCR_"I '$$ACTLOC^RORRP015(+Y) "
S:FLAGS'["I" SCR=SCR_"I $$ACTLOC^RORRP015(+Y) "
;--- Get the list of locations
S BUF="@;.01;2I;3I;3.5I",TMP="P"_$S(FLAGS["B":"B",1:"")
D LIST^DIC(44,,BUF,TMP,NUMBER,.FROM,PART,"B",SCR,,,"RORMSG")
I $G(DIERR) D D RPCSTK^RORERR(.RESULTS,RC) Q
. S RC=$$DBS^RORERR("RORMSG",-9,,,44)
. K ^TMP("DILIST",$J)
;--- Populate the Active field if both flags are used
I FLAGS["I",FLAGS["A" S I=0 D
. F S I=$O(@RESULTS@(I)) Q:I="" D
. . S $P(@RESULTS@(I,0),U,6)=$$ACTLOC(+@RESULTS@(I,0))
;--- Success
S TMP=$G(^TMP("DILIST",$J,0)),BUF=+$P(TMP,U)
K ^TMP("DILIST",$J,0)
S:$P(TMP,U,3) $P(BUF,U,2,3)=$G(FROM)_U_$G(FROM("IEN"))
S @RESULTS@(0)=BUF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORRP015 8323 printed Dec 13, 2024@01:42:58 Page 2
RORRP015 ;HCIOFO/SG - RPC: DIVISIONS AND HOSPITAL LOCATIONS ; 5/25/11 11:49am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**1,15**;Feb 17, 2006;Build 27
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #1246 WIN^DGPMDDCF (supported)
+6 ; #417 Access to the file #40.8 (controlled)
+7 ; #10040 Access to the HOSPITAL LOCATION file (supported)
+8 ;
+9 QUIT
+10 ;
+11 ;***** CHECKS IF THE HOSPITAL LOCATION IS ACTIVE
+12 ;
+13 ; LOCIEN IEN of the hospital location
+14 ;
ACTLOC(LOCIEN) ;
+1 NEW D0,DGPMOS,RDT,X
+2 ; An OOS entry
if $GET(^SC(LOCIEN,"OOS"))
QUIT 0
+3 SET D0=+$GET(^SC(LOCIEN,42))
+4 ; Check if ward is inactive
IF D0>0
DO WIN^DGPMDDCF
QUIT 'X
+5 ; No inactivation date
SET X=$GET(^SC(LOCIEN,"I"))
if '$PIECE(X,U)
QUIT 1
+6 SET RDT=+$PIECE(X,U,2)
+7 ; Check reactivation date
IF DT>$PIECE(X,U)
if 'RDT!(DT<RDT)
QUIT 0
+8 QUIT 1
+9 ;
+10 ;***** RETURNS THE LIST OF DIVISIONS
+11 ; RPC: [ROR LIST DIVISIONS]
+12 ;
+13 ; .RESULTS Reference to a local variable where the results
+14 ; are returned to.
+15 ;
+16 ; [PART] The partial match restriction.
+17 ;
+18 ; [FLAGS] Flags that control the execution (can be combined)
+19 ; B Backwards. Traverses the index in the opposite
+20 ; direction of normal traversal.
+21 ;
+22 ; [NUMBER] Maximum number of entries to return. A value of "*"
+23 ; or no value in this parameter designates all entries.
+24 ;
+25 ; [FROM] The index entry(s) from which to begin the list
+26 ; ^01: FromName
+27 ; ^02: FromIEN
+28 ;
+29 ; For example, a FROM value of "VA" would list entries
+30 ; following VA. You can use the 2-nd and 3-rd "^"-
+31 ; pieces of the @RESULTS@(0) node to continue the
+32 ; listing in the subsequent procedure calls.
+33 ;
+34 ; NOTE: The FROM value itself is not included in
+35 ; the resulting list.
+36 ;
+37 ; The ^TMP("DILIST",$J) global node is used by the procedure.
+38 ;
+39 ; See description of the LIST^DIC for more details about the
+40 ; PART, NUMBER and FROM parameters.
+41 ;
+42 ; Return Values:
+43 ;
+44 ; A negative value of the first "^"-piece of the @RESULTS@(0)
+45 ; indicates an error (see the RPCSTK^RORERR procedure for more
+46 ; details).
+47 ;
+48 ; Otherwise, number of divisions and the value of the FROM parameter
+49 ; for the next procedure call are returned in the @RESULTS@(0) and
+50 ; the subsequent nodes of the global array contain the divisions.
+51 ;
+52 ; @RESULTS@(0) Result Descriptor
+53 ; ^01: Number of divisions
+54 ; ^02: FromName
+55 ; ^03: FromIEN
+56 ;
+57 ; @RESULTS@(i) Division
+58 ; ^01: IEN
+59 ; ^02: Name
+60 ; ^03: Facility Number
+61 ; ^04: Institution IEN
+62 ;
DIVLIST(RESULTS,PART,FLAGS,NUMBER,FROM) ;
+1 NEW BUF,RC,RORERRDL,RORMSG,TMP,DIERR
+2 DO CLEAR^RORERR("DIVLIST^RORRP015",1)
+3 KILL RESULTS
SET RESULTS=$NAME(^TMP("DILIST",$JOB))
KILL @RESULTS
+4 ;--- Check the parameters
+5 SET PART=$GET(PART)
SET FLAGS=$GET(FLAGS)
+6 ;user selects All Divisions
IF PART="??"
SET PART=""
+7 SET NUMBER=$SELECT($GET(NUMBER)>0:+NUMBER,1:"*")
+8 ;--- Setup the start point
+9 IF $GET(FROM)'=""
Begin DoDot:1
+10 if $PIECE(FROM,U,2)>0
SET FROM("IEN")=+$PIECE(FROM,U,2)
End DoDot:1
SET FROM=$PIECE(FROM,U)
+11 ;--- Get the list of divisions
+12 SET BUF="@;.01;1;.07I"
SET TMP="P"_$SELECT(FLAGS["B":"B",1:"")
+13 DO LIST^DIC(40.8,,BUF,TMP,NUMBER,.FROM,PART,"B",,,,"RORMSG")
+14 IF $GET(DIERR)
Begin DoDot:1
+15 SET RC=$$DBS^RORERR("RORMSG",-9,,,40.8)
+16 KILL ^TMP("DILIST",$JOB)
End DoDot:1
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+17 ;--- Success
+18 SET TMP=$GET(^TMP("DILIST",$JOB,0))
SET BUF=+$PIECE(TMP,U)
+19 KILL ^TMP("DILIST",$JOB,0)
+20 if $PIECE(TMP,U,3)
SET $PIECE(BUF,U,2,3)=$GET(FROM)_U_$GET(FROM("IEN"))
+21 SET @RESULTS@(0)=BUF
+22 QUIT
+23 ;
+24 ;***** RETURNS THE LIST OF HOSPITAL LOCATIONS
+25 ; RPC: [ROR LIST HOSPITAL LOCATIONS]
+26 ;
+27 ; .RESULTS Reference to a local variable where the results
+28 ; are returned to.
+29 ;
+30 ; [HLTYPES] List of location types separated by commas (internal
+31 ; values of the TYPE field of the HOSPITAL LOCATION
+32 ; file). Only locations of the types defined by this
+33 ; parameter are selected by the procedure. By default
+34 ; ($G(HLTYPES)=""), all locations are selected.
+35 ;
+36 ; [DIVIEN] Division IEN. If this parameter is defined and
+37 ; greater than zero then only the locations associated
+38 ; with this division will be selected.
+39 ;
+40 ; [PART] The partial match restriction.
+41 ;
+42 ; [FLAGS] Flags that control the execution (can be combined):
+43 ; A Include active locations (default)
+44 ; B Backwards. Traverses the index in the opposite
+45 ; direction of normal traversal.
+46 ; I Include inactive locations
+47 ;
+48 ; [NUMBER] Maximum number of entries to return. A value of "*"
+49 ; or no value in this parameter designates all entries.
+50 ;
+51 ; [FROM] The index entry(s) from which to begin the list
+52 ; ^01: FromName
+53 ; ^02: FromIEN
+54 ;
+55 ; For example, a FROM value of "VA" would list entries
+56 ; following VA. You can use the 2-nd and 3-rd "^"-
+57 ; pieces of the @RESULTS@(0) node to continue the
+58 ; listing in the subsequent procedure calls.
+59 ;
+60 ; NOTE: The FROM value itself is not included in
+61 ; the resulting list.
+62 ;
+63 ; The ^TMP("DILIST",$J) global node is used by the procedure.
+64 ;
+65 ; See description of the LIST^DIC for more details about the
+66 ; PART, NUMBER and FROM parameters.
+67 ;
+68 ; Return Values:
+69 ;
+70 ; A negative value of the first "^"-piece of the @RESULTS@(0)
+71 ; indicates an error (see the RPCSTK^RORERR procedure for more
+72 ; details).
+73 ;
+74 ; Otherwise, number of hospital locations and the value of the
+75 ; FROM parameter for the next procedure call are returned in
+76 ; the @RESULTS@(0) and the subsequent nodes of the global array
+77 ; contain the locations.
+78 ;
+79 ; @RESULTS@(0) Result Descriptor
+80 ; ^01: Number of locations
+81 ; ^02: FromName
+82 ; ^03: FromIEN
+83 ;
+84 ; @RESULTS@(i) Hospital Location
+85 ; ^01: IEN
+86 ; ^02: Name
+87 ; ^03: Type (internal)
+88 ; ^04: Institution IEN
+89 ; ^05: Division IEN
+90 ; ^06: Active (0/1)
+91 ;
+92 ; NOTE: The 6th "^"-piece of the location record (Active) is
+93 ; populated only if both "A" and "I" flags are used.
+94 ;
HLOCLIST(RESULTS,HLTYPES,DIVIEN,PART,FLAGS,NUMBER,FROM) ;
+1 NEW BUF,I,RC,RORERRDL,RORHLT,RORMSG,SCR,TMP
+2 DO CLEAR^RORERR("HLOCLIST^RORRP015",1)
+3 KILL RESULTS
SET RESULTS=$NAME(^TMP("DILIST",$JOB))
KILL @RESULTS
+4 ;--- Check the parameters
+5 SET HLTYPES=$$UP^XLFSTR($TRANSLATE($GET(HLTYPES)," "))
+6 FOR I=1:1
SET TMP=$PIECE(HLTYPES,",",I)
if TMP=""
QUIT
SET RORHLT(TMP)=""
+7 SET DIVIEN=$SELECT($GET(DIVIEN)>0:+DIVIEN,1:0)
+8 SET PART=$GET(PART)
SET FLAGS=$GET(FLAGS)
+9 SET NUMBER=$SELECT($GET(NUMBER)>0:+NUMBER,1:"*")
+10 ;--- If neither "A" nor "I" flag is provided, add the "A" (default)
+11 if $TRANSLATE(FLAGS,"AI")=FLAGS
SET FLAGS=FLAGS_"A"
+12 ;--- Setup the start point
+13 IF $GET(FROM)'=""
Begin DoDot:1
+14 if $PIECE(FROM,U,2)>0
SET FROM("IEN")=+$PIECE(FROM,U,2)
End DoDot:1
SET FROM=$PIECE(FROM,U)
+15 ;--- Compile the screen logic (be careful with naked references)
+16 SET SCR=""
+17 if $DATA(RORHLT)>1
Begin DoDot:1
+18 SET SCR=SCR_"S D=$P($G(^(0)),U,3) I D'="""",$D(RORHLT(D)) "
End DoDot:1
+19 if DIVIEN
SET SCR=SCR_"I $P($G(^(0)),U,15)=DIVIEN "
+20 if FLAGS'["A"
SET SCR=SCR_"I '$$ACTLOC^RORRP015(+Y) "
+21 if FLAGS'["I"
SET SCR=SCR_"I $$ACTLOC^RORRP015(+Y) "
+22 ;--- Get the list of locations
+23 SET BUF="@;.01;2I;3I;3.5I"
SET TMP="P"_$SELECT(FLAGS["B":"B",1:"")
+24 DO LIST^DIC(44,,BUF,TMP,NUMBER,.FROM,PART,"B",SCR,,,"RORMSG")
+25 IF $GET(DIERR)
Begin DoDot:1
+26 SET RC=$$DBS^RORERR("RORMSG",-9,,,44)
+27 KILL ^TMP("DILIST",$JOB)
End DoDot:1
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+28 ;--- Populate the Active field if both flags are used
+29 IF FLAGS["I"
IF FLAGS["A"
SET I=0
Begin DoDot:1
+30 FOR
SET I=$ORDER(@RESULTS@(I))
if I=""
QUIT
Begin DoDot:2
+31 SET $PIECE(@RESULTS@(I,0),U,6)=$$ACTLOC(+@RESULTS@(I,0))
End DoDot:2
End DoDot:1
+32 ;--- Success
+33 SET TMP=$GET(^TMP("DILIST",$JOB,0))
SET BUF=+$PIECE(TMP,U)
+34 KILL ^TMP("DILIST",$JOB,0)
+35 if $PIECE(TMP,U,3)
SET $PIECE(BUF,U,2,3)=$GET(FROM)_U_$GET(FROM("IEN"))
+36 SET @RESULTS@(0)=BUF
+37 QUIT
