HMPXGSD.m

HMPXGSD ; ASMR/hrubovcak - Scheduling data retrieval ;Nov 20, 2015 01:49:50

 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2**;Sep 01, 2011;Build 28

 ;Per VA Directive 6402, this routine should not be modified.

 ;

 Q

 ;

 ; DE2818, code below adapted from CLINLOC^ORWU

CLINLOC(RSLT,FROM,DIR) ; return list of clinics from HOSPITAL LOCATION file (#44)

 ; all 3 arguments required

 ; RSLT=returned list (passed by reference), FROM=text to $ORDER from, DIR=$ORDER direction

 ; RSLT(counter) = IEN^location name

 N I,IEN,LOCNM  ; counter, internal entry number, location name

 S I=0,LOCNM=$G(FROM)

 F  S LOCNM=$O(^SC("B",LOCNM),DIR) Q:LOCNM=""  D  ; ICR 10040

 . S IEN="" F  S IEN=$O(^SC("B",LOCNM,IEN),DIR) Q:'IEN  D

 ..  Q:'($P($G(^SC(IEN,0)),U,3)="C")  ; check (#2) TYPE [3S], must be clinic

 ..  Q:'$$ACTLOC(IEN)  ; must be active

 ..  S I=I+1,RSLT(I)=IEN_"^"_LOCNM

 ;

 Q

 ;

 ; DE2818, code below adapted from ACTLOC^ORWU

ACTLOC(LOC) ; Boolean function, TRUE if active hospital location

 ; LOC - IEN in HOSPITAL LOCATION file, ICR 10040

 ; IND - the "I" node, ^SC(D0,I) = (#2505) INACTIVATE DATE [1D] ^ (#2506) REACTIVATE DATE [2D] ^

 ; D0, X - used by WIN^DGPMDDCF

 N D0,IND,X

 Q:+$G(^SC(LOC,"OOS")) 0  ; (#50.01) OCCASION OF SERVICE CLINIC?, screen entry

 S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X  ; check out-of-service wards, ICR 1246

 S IND=$G(^SC(LOC,"I")) Q:'IND 1  ; INACTIVATE DATE not found

 I DT>$P(IND,U)&($P(IND,U,2)=""!(DT<$P(IND,U,2))) Q 0  ; check REACTIVATE DATE

 Q 1  ; active

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---HMPXGSD   1536     printed  Sep 02, 2024@18:40:09                                                                                                                                                                                                     Page 2

HMPXGSD   ; ASMR/hrubovcak - Scheduling data retrieval ;Nov 20, 2015 01:49:50

 +1       ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2**;Sep 01, 2011;Build 28

 +2       ;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4        QUIT 

 +5       ;

 +6       ; DE2818, code below adapted from CLINLOC^ORWU

CLINLOC(RSLT,FROM,DIR) ; return list of clinics from HOSPITAL LOCATION file (#44)

 +1       ; all 3 arguments required

 +2       ; RSLT=returned list (passed by reference), FROM=text to $ORDER from, DIR=$ORDER direction

 +3       ; RSLT(counter) = IEN^location name

 +4       ; counter, internal entry number, location name

           NEW I,IEN,LOCNM

 +5        SET I=0

           SET LOCNM=$GET(FROM)

 +6       ; ICR 10040

           FOR 

               SET LOCNM=$ORDER(^SC("B",LOCNM),DIR)

               if LOCNM=""

                   QUIT 

               Begin DoDot:1

 +7                SET IEN=""

                   FOR 

                       SET IEN=$ORDER(^SC("B",LOCNM,IEN),DIR)

                       if 'IEN

                           QUIT 

                       Begin DoDot:2

 +8       ; check (#2) TYPE [3S], must be clinic

                           if '($PIECE($GET(^SC(IEN,0)),U,3)="C")

                               QUIT 

 +9       ; must be active

                           if '$$ACTLOC(IEN)

                               QUIT 

 +10                       SET I=I+1

                           SET RSLT(I)=IEN_"^"_LOCNM

                       End DoDot:2

               End DoDot:1

 +11      ;

 +12       QUIT 

 +13      ;

 +14      ; DE2818, code below adapted from ACTLOC^ORWU

ACTLOC(LOC) ; Boolean function, TRUE if active hospital location

 +1       ; LOC - IEN in HOSPITAL LOCATION file, ICR 10040

 +2       ; IND - the "I" node, ^SC(D0,I) = (#2505) INACTIVATE DATE [1D] ^ (#2506) REACTIVATE DATE [2D] ^

 +3       ; D0, X - used by WIN^DGPMDDCF

 +4        NEW D0,IND,X

 +5       ; (#50.01) OCCASION OF SERVICE CLINIC?, screen entry

           if +$GET(^SC(LOC,"OOS"))

               QUIT 0

 +6       ; check out-of-service wards, ICR 1246

           SET D0=+$GET(^SC(LOC,42))

           IF D0

               DO WIN^DGPMDDCF

               QUIT 'X

 +7       ; INACTIVATE DATE not found

           SET IND=$GET(^SC(LOC,"I"))

           if 'IND

               QUIT 1

 +8       ; check REACTIVATE DATE

           IF DT>$PIECE(IND,U)&($PIECE(IND,U,2)=""!(DT<$PIECE(IND,U,2)))

               QUIT 0

 +9       ; active

           QUIT 1

 +10      ;