- DGPFUT ;ALB/RPM - PRF UTILITIES ; 6/7/05 3:13pm
- ;;5.3;Registration;**425,554,650,1015**;Aug 13, 1993;Build 21
- ;
- ;ihs/cmi/maw 08/02/2012 PATCH 1015 check in MPIOK for MPI routines
- Q ;no direct entry
- ;
- ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS) ;wrap FileMan Classic Reader call
- ;
- ; Input
- ; DGDIR0 - DIR(0) string
- ; DGDIRA - DIR("A") string
- ; DGDIRB - DIR("B") string
- ; DGDIRH - DIR("?") string
- ; DGDIRS - DIR("S") string
- ;
- ; Output
- ; Function Value - Internal value returned from ^DIR or -1 if user
- ; up-arrows, double up-arrows or the read times out.
- ;
- ; DIR(0) type Results
- ; ------------ -------------------------------
- ; DD IEN of selected entry
- ; Pointer IEN of selected entry
- ; Set of Codes Internal value of code
- ; Yes/No 0 for No, 1 for Yes
- ;
- N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ;^DIR variables
- ;
- S DIR(0)=DGDIR0
- S DIR("A")=$G(DGDIRA)
- I $G(DGDIRB)]"" S DIR("B")=DGDIRB
- I $D(DGDIRH) S DIR("?")=DGDIRH
- I $G(DGDIRS)]"" S DIR("S")=DGDIRS
- D ^DIR
- Q $S($D(DUOUT):-1,$D(DTOUT):-1,$D(DIROUT):-1,X="@":"@",1:$P(Y,U))
- ;
- CONTINUE() ;pause display
- ;
- ; Input: none
- ;
- ; Output: 1 - continue
- ; 0 - quit
- ;
- N DIR,Y
- S DIR(0)="E" D ^DIR
- Q $S(Y'=1:0,1:1)
- ;
- VALID(DGRTN,DGFILE,DGIP,DGERR) ;validate input values before filing
- ;
- ; Input:
- ; DGRTN - (required) Routine name that contains $TEXT table
- ; DGFILE - (required) File number for input values
- ; DGIP - (required) Input value array
- ; DGERR - (optional) Returns error message passed by reference
- ;
- ; Output:
- ; Function Value - Returns 1 on all values valid, 0 on failure
- ;
- I $G(DGRTN)=""!('$G(DGFILE)) Q 0
- N DGVLD ;function return value
- N DGFXR ;node name to field xref array
- N DGREQ ;array of required fields
- N DGWP ;word processing flag
- N DGN ;array node name
- ;
- S DGVLD=1
- S DGN=""
- D BLDXR(DGRTN,.DGFXR)
- ;
- F S DGN=$O(DGFXR(DGN)) Q:DGN="" D Q:'DGVLD
- . S DGREQ=$P(DGFXR(DGN),U,2)
- . S DGWP=$P(DGFXR(DGN),U,3)
- . I DGREQ D ;required field check
- . . I DGWP,'$$CKWP("DGIP(DGN)") S DGVLD=0 Q
- . . I 'DGWP,$G(DGIP(DGN))']"" S DGVLD=0 Q
- . I 'DGVLD D Q
- . . S DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" REQUIRED"
- . Q:DGWP ;don't check word processing fields for invalid values
- . ;check for invalid values
- . I '$$TESTVAL(DGFILE,+DGFXR(DGN),$P($G(DGIP(DGN)),U)) D Q
- . . S DGVLD=0,DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" NOT VALID"
- Q DGVLD
- ;
- BLDXR(DGRTN,DGFLDA) ;build name/field xref array
- ;This procedure reads in the text from the XREF line tag of the DGRTN
- ;input parameter and loads name/field xref array with parsed line data.
- ;
- ; Input:
- ; DGRTN - (required) Routine name that contains the XREF line tag
- ; DGFLDA - (required) Array name for name/field xref passed by
- ; reference
- ;
- ; Output:
- ; Function Value - Returns 1 on success, 0 on failure
- ; DGFLDA - Name/field xref array
- ; format: DGFLDA(subscript)=field#^required?^word proc?
- ;
- S DGRTN=$G(DGRTN)
- Q:DGRTN=""
- I $E(DGRTN,1)'="^" S DGRTN="^"_DGRTN
- Q:($T(@DGRTN)="")
- N DGTAG
- N DGOFF
- N DGLINE
- ;
- F DGOFF=1:1 S DGTAG="XREF+"_DGOFF_DGRTN,DGLINE=$T(@DGTAG) Q:DGLINE="" D
- . S DGFLDA($P(DGLINE,";",3))=$P(DGLINE,";",4)_U_+$P(DGLINE,";",5)_U_+$P(DGLINE,";",6)
- Q
- ;
- CKWP(DGROOT) ;ck word processing required fields
- ;This function verifies that at least one line in the word processing
- ;array contains text more than one space long.
- ;
- ; Input:
- ; DGROOT - (required) Word processing root
- ;
- ; Output:
- ; Function Value - Returns 1 on success, 0 on failure
- ;
- N DGLIN
- N DGRSLT
- S DGRSLT=0
- I $D(@DGROOT) D
- . S DGLIN=""
- . F S DGLIN=$O(@DGROOT@(DGLIN)) Q:DGLIN="" D Q:DGRSLT
- . . I $G(@DGROOT@(DGLIN,0))]"",@DGROOT@(DGLIN,0)'=" " S DGRSLT=1
- Q DGRSLT
- ;
- TESTVAL(DGFIL,DGFLD,DGVAL) ;validate individual value against field def
- ;
- ; Input:
- ; DGFIL - (required) File number
- ; DGFLD - (required) Field number
- ; DGVAL - (required) Field value to be validated
- ;
- ; Output:
- ; Function Value - Returns 1 if value is valid, 0 if value is invalid
- ;
- N DGVALEX ;external value after conversion
- N DGTYP ;field type
- N DGRSLT ;results of CHK^DIE
- N VALID ;function results
- ;
- S VALID=1
- I $G(DGFIL)>0,($G(DGFLD)>0),($G(DGVAL)'="") D
- . S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL)
- . I DGVALEX="" S VALID=0 Q
- . I $$GET1^DID(DGFIL,DGFLD,"","TYPE")'["POINTER" D
- . . D CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT) I DGRSLT="^" S VALID=0 Q
- Q VALID
- ;
- STATUS(DGACT) ;calculate the assignment STATUS given an ACTION code
- ;
- ; Input:
- ; DGACT - (required) Action (.03) field value for PRF ASSIGNMENT
- ; HISTORY (#26.14) file in internal or external format
- ;
- ; Output:
- ; Function Value - Status value on success, -1 on failure
- ;
- N DGERR ;FM message root
- N DGRSLT ;CHK^DIE result array
- N DGSTAT ;calculated status value
- ;
- S DGSTAT=-1
- I $G(DGACT)]"" D
- . I DGACT?1.N S DGACT=$$EXTERNAL^DILFD(26.14,.03,"F",DGACT,"DGERR")
- . Q:$D(DGERR)
- . D CHK^DIE(26.14,.03,"E",DGACT,.DGRSLT,"DGERR")
- . Q:$D(DGERR)
- . I DGRSLT(0)="INACTIVATE"!(DGRSLT(0)="ENTERED IN ERROR") S DGSTAT=0
- . E S DGSTAT=1
- Q DGSTAT
- ;
- MPIOK(DGDFN,DGICN) ;return national ICN
- ;This function verifies that a given patient has a valid national
- ;Integration Control Number.
- ;
- ; Supported DBIA #2701: The supported DBIA is used to access MPI
- ; APIs to retrieve ICN and determine if ICN
- ; is local.
- ;
- ; Input:
- ; DGDFN - (required) IEN of patient in PATIENT (#2) file
- ; DGICN - (optional) passed by reference to contain national ICN
- ;
- ; Output:
- ; Function Value - 1 on valid national ICN;
- ; 0 on failure
- ; DGICN - Patient's Integrated Control Number
- ;
- I '$T(GETICN^MPIF001) Q 1 ;ihs/cmi/maw 08/02/2012 PATCH 1015 not using ICN at all sites yet
- N DGRSLT
- S DGRSLT=0
- I $G(DGDFN)>0 D
- . S DGICN=$$GETICN^MPIF001(DGDFN)
- . ;
- . ;ICN must be valid
- . Q:(DGICN'>0)
- . ;
- . ;ICN must not be local
- . Q:$$IFLOCAL^MPIF001(DGDFN)
- . ;
- . S DGRSLT=1
- Q DGRSLT
- ;
- GETNXTF(DGDFN,DGLTF) ;get previous treating facility
- ;This function will return the treating facility with a DATE LAST
- ;TREATED value immediately prior to the date for the treating facility
- ;passed as the second parameter. The most recent treating facility
- ;will be returned when the second parameter is missing, null, or zero.
- ;
- ; Input:
- ; DGDFN - pointer to patient in PATIENT (#2) file
- ; DGLTF - (optional) last treating facility [default=0]
- ;
- ; Output:
- ; Function value - previous facility as a pointer to INSTITUTION (#4)
- ; file on success; 0 on failure
- ;
- N DGARR ;fully subscripted array node
- N DGDARR ;date sorted treating facilities
- N DGINST ;institution pointer
- N DGNAM ;name of sorted treating facilities array
- N DGTFARR ;array of non-local treating facilities
- ;
- ;
- I $G(DGDFN)>0,$$BLDTFL^DGPFUT2(DGDFN,.DGTFARR) D
- . ;
- . ;validate last treating facility input parameter
- . S DGLTF=+$G(DGLTF)
- . S DGLTF=$S(DGLTF&($D(DGTFARR(DGLTF))):DGLTF,1:0)
- . ;
- . ;build date sorted list
- . S DGINST=0
- . F S DGINST=$O(DGTFARR(DGINST)) Q:'DGINST D
- . . S DGDARR(DGTFARR(DGINST),DGINST)=""
- . ;
- . ;find entry for previous treating facility
- . S DGNAM="DGDARR"
- . S DGARR=$QUERY(@DGNAM@(""),-1)
- . I DGLTF,DGARR]"" D
- . . I $QS(DGARR,2)'=DGLTF D
- . . . F S DGARR=$QUERY(@DGARR,-1) Q:+$QS(DGARR,2)=DGLTF
- . . S DGARR=$QUERY(@DGARR,-1)
- ;
- Q $S($G(DGARR)]"":+$QS(DGARR,2),1:0)
- ;
- ISDIV(DGSITE) ;is site local division
- ;
- ; Input:
- ; DGSITE - pointer to INSTITUTION (#4) file
- ;
- ; Output:
- ; Function value - 1 on success; 0 on failure
- ;
- S DGSITE=+$G(DGSITE)
- Q $S($D(^DG(40.8,"AD",DGSITE)):1,1:0)
- DGPFUT ;ALB/RPM - PRF UTILITIES ; 6/7/05 3:13pm
- +1 ;;5.3;Registration;**425,554,650,1015**;Aug 13, 1993;Build 21
- +2 ;
- +3 ;ihs/cmi/maw 08/02/2012 PATCH 1015 check in MPIOK for MPI routines
- +4 ;no direct entry
- QUIT
- +5 ;
- ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS) ;wrap FileMan Classic Reader call
- +1 ;
- +2 ; Input
- +3 ; DGDIR0 - DIR(0) string
- +4 ; DGDIRA - DIR("A") string
- +5 ; DGDIRB - DIR("B") string
- +6 ; DGDIRH - DIR("?") string
- +7 ; DGDIRS - DIR("S") string
- +8 ;
- +9 ; Output
- +10 ; Function Value - Internal value returned from ^DIR or -1 if user
- +11 ; up-arrows, double up-arrows or the read times out.
- +12 ;
- +13 ; DIR(0) type Results
- +14 ; ------------ -------------------------------
- +15 ; DD IEN of selected entry
- +16 ; Pointer IEN of selected entry
- +17 ; Set of Codes Internal value of code
- +18 ; Yes/No 0 for No, 1 for Yes
- +19 ;
- +20 ;^DIR variables
- NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
- +21 ;
- +22 SET DIR(0)=DGDIR0
- +23 SET DIR("A")=$GET(DGDIRA)
- +24 IF $GET(DGDIRB)]""
- SET DIR("B")=DGDIRB
- +25 IF $DATA(DGDIRH)
- SET DIR("?")=DGDIRH
- +26 IF $GET(DGDIRS)]""
- SET DIR("S")=DGDIRS
- +27 DO ^DIR
- +28 QUIT $SELECT($DATA(DUOUT):-1,$DATA(DTOUT):-1,$DATA(DIROUT):-1,X="@":"@",1:$PIECE(Y,U))
- +29 ;
- CONTINUE() ;pause display
- +1 ;
- +2 ; Input: none
- +3 ;
- +4 ; Output: 1 - continue
- +5 ; 0 - quit
- +6 ;
- +7 NEW DIR,Y
- +8 SET DIR(0)="E"
- DO ^DIR
- +9 QUIT $SELECT(Y'=1:0,1:1)
- +10 ;
- VALID(DGRTN,DGFILE,DGIP,DGERR) ;validate input values before filing
- +1 ;
- +2 ; Input:
- +3 ; DGRTN - (required) Routine name that contains $TEXT table
- +4 ; DGFILE - (required) File number for input values
- +5 ; DGIP - (required) Input value array
- +6 ; DGERR - (optional) Returns error message passed by reference
- +7 ;
- +8 ; Output:
- +9 ; Function Value - Returns 1 on all values valid, 0 on failure
- +10 ;
- +11 IF $GET(DGRTN)=""!('$GET(DGFILE))
- QUIT 0
- +12 ;function return value
- NEW DGVLD
- +13 ;node name to field xref array
- NEW DGFXR
- +14 ;array of required fields
- NEW DGREQ
- +15 ;word processing flag
- NEW DGWP
- +16 ;array node name
- NEW DGN
- +17 ;
- +18 SET DGVLD=1
- +19 SET DGN=""
- +20 DO BLDXR(DGRTN,.DGFXR)
- +21 ;
- +22 FOR
- SET DGN=$ORDER(DGFXR(DGN))
- IF DGN=""
- QUIT
- Begin DoDot:1
- +23 SET DGREQ=$PIECE(DGFXR(DGN),U,2)
- +24 SET DGWP=$PIECE(DGFXR(DGN),U,3)
- +25 ;required field check
- IF DGREQ
- Begin DoDot:2
- +26 IF DGWP
- IF '$$CKWP("DGIP(DGN)")
- SET DGVLD=0
- QUIT
- +27 IF 'DGWP
- IF $GET(DGIP(DGN))']""
- SET DGVLD=0
- QUIT
- End DoDot:2
- +28 IF 'DGVLD
- Begin DoDot:2
- +29 SET DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" REQUIRED"
- End DoDot:2
- QUIT
- +30 ;don't check word processing fields for invalid values
- IF DGWP
- QUIT
- +31 ;check for invalid values
- +32 IF '$$TESTVAL(DGFILE,+DGFXR(DGN),$PIECE($GET(DGIP(DGN)),U))
- Begin DoDot:2
- +33 SET DGVLD=0
- SET DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" NOT VALID"
- End DoDot:2
- QUIT
- End DoDot:1
- IF 'DGVLD
- QUIT
- +34 QUIT DGVLD
- +35 ;
- BLDXR(DGRTN,DGFLDA) ;build name/field xref array
- +1 ;This procedure reads in the text from the XREF line tag of the DGRTN
- +2 ;input parameter and loads name/field xref array with parsed line data.
- +3 ;
- +4 ; Input:
- +5 ; DGRTN - (required) Routine name that contains the XREF line tag
- +6 ; DGFLDA - (required) Array name for name/field xref passed by
- +7 ; reference
- +8 ;
- +9 ; Output:
- +10 ; Function Value - Returns 1 on success, 0 on failure
- +11 ; DGFLDA - Name/field xref array
- +12 ; format: DGFLDA(subscript)=field#^required?^word proc?
- +13 ;
- +14 SET DGRTN=$GET(DGRTN)
- +15 IF DGRTN=""
- QUIT
- +16 IF $EXTRACT(DGRTN,1)'="^"
- SET DGRTN="^"_DGRTN
- +17 IF ($TEXT(@DGRTN)="")
- QUIT
- +18 NEW DGTAG
- +19 NEW DGOFF
- +20 NEW DGLINE
- +21 ;
- +22 FOR DGOFF=1:1
- SET DGTAG="XREF+"_DGOFF_DGRTN
- SET DGLINE=$TEXT(@DGTAG)
- IF DGLINE=""
- QUIT
- Begin DoDot:1
- +23 SET DGFLDA($PIECE(DGLINE,";",3))=$PIECE(DGLINE,";",4)_U_+$PIECE(DGLINE,";",5)_U_+$PIECE(DGLINE,";",6)
- End DoDot:1
- +24 QUIT
- +25 ;
- CKWP(DGROOT) ;ck word processing required fields
- +1 ;This function verifies that at least one line in the word processing
- +2 ;array contains text more than one space long.
- +3 ;
- +4 ; Input:
- +5 ; DGROOT - (required) Word processing root
- +6 ;
- +7 ; Output:
- +8 ; Function Value - Returns 1 on success, 0 on failure
- +9 ;
- +10 NEW DGLIN
- +11 NEW DGRSLT
- +12 SET DGRSLT=0
- +13 IF $DATA(@DGROOT)
- Begin DoDot:1
- +14 SET DGLIN=""
- +15 FOR
- SET DGLIN=$ORDER(@DGROOT@(DGLIN))
- IF DGLIN=""
- QUIT
- Begin DoDot:2
- +16 IF $GET(@DGROOT@(DGLIN,0))]""
- IF @DGROOT@(DGLIN,0)'=" "
- SET DGRSLT=1
- End DoDot:2
- IF DGRSLT
- QUIT
- End DoDot:1
- +17 QUIT DGRSLT
- +18 ;
- TESTVAL(DGFIL,DGFLD,DGVAL) ;validate individual value against field def
- +1 ;
- +2 ; Input:
- +3 ; DGFIL - (required) File number
- +4 ; DGFLD - (required) Field number
- +5 ; DGVAL - (required) Field value to be validated
- +6 ;
- +7 ; Output:
- +8 ; Function Value - Returns 1 if value is valid, 0 if value is invalid
- +9 ;
- +10 ;external value after conversion
- NEW DGVALEX
- +11 ;field type
- NEW DGTYP
- +12 ;results of CHK^DIE
- NEW DGRSLT
- +13 ;function results
- NEW VALID
- +14 ;
- +15 SET VALID=1
- +16 IF $GET(DGFIL)>0
- IF ($GET(DGFLD)>0)
- IF ($GET(DGVAL)'="")
- Begin DoDot:1
- +17 SET DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL)
- +18 IF DGVALEX=""
- SET VALID=0
- QUIT
- +19 IF $$GET1^DID(DGFIL,DGFLD,"","TYPE")'["POINTER"
- Begin DoDot:2
- +20 DO CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT)
- IF DGRSLT="^"
- SET VALID=0
- QUIT
- End DoDot:2
- End DoDot:1
- +21 QUIT VALID
- +22 ;
- STATUS(DGACT) ;calculate the assignment STATUS given an ACTION code
- +1 ;
- +2 ; Input:
- +3 ; DGACT - (required) Action (.03) field value for PRF ASSIGNMENT
- +4 ; HISTORY (#26.14) file in internal or external format
- +5 ;
- +6 ; Output:
- +7 ; Function Value - Status value on success, -1 on failure
- +8 ;
- +9 ;FM message root
- NEW DGERR
- +10 ;CHK^DIE result array
- NEW DGRSLT
- +11 ;calculated status value
- NEW DGSTAT
- +12 ;
- +13 SET DGSTAT=-1
- +14 IF $GET(DGACT)]""
- Begin DoDot:1
- +15 IF DGACT?1.N
- SET DGACT=$$EXTERNAL^DILFD(26.14,.03,"F",DGACT,"DGERR")
- +16 IF $DATA(DGERR)
- QUIT
- +17 DO CHK^DIE(26.14,.03,"E",DGACT,.DGRSLT,"DGERR")
- +18 IF $DATA(DGERR)
- QUIT
- +19 IF DGRSLT(0)="INACTIVATE"!(DGRSLT(0)="ENTERED IN ERROR")
- SET DGSTAT=0
- +20 IF '$TEST
- SET DGSTAT=1
- End DoDot:1
- +21 QUIT DGSTAT
- +22 ;
- MPIOK(DGDFN,DGICN) ;return national ICN
- +1 ;This function verifies that a given patient has a valid national
- +2 ;Integration Control Number.
- +3 ;
- +4 ; Supported DBIA #2701: The supported DBIA is used to access MPI
- +5 ; APIs to retrieve ICN and determine if ICN
- +6 ; is local.
- +7 ;
- +8 ; Input:
- +9 ; DGDFN - (required) IEN of patient in PATIENT (#2) file
- +10 ; DGICN - (optional) passed by reference to contain national ICN
- +11 ;
- +12 ; Output:
- +13 ; Function Value - 1 on valid national ICN;
- +14 ; 0 on failure
- +15 ; DGICN - Patient's Integrated Control Number
- +16 ;
- +17 ;ihs/cmi/maw 08/02/2012 PATCH 1015 not using ICN at all sites yet
- IF '$TEXT(GETICN^MPIF001)
- QUIT 1
- +18 NEW DGRSLT
- +19 SET DGRSLT=0
- +20 IF $GET(DGDFN)>0
- Begin DoDot:1
- +21 SET DGICN=$$GETICN^MPIF001(DGDFN)
- +22 ;
- +23 ;ICN must be valid
- +24 IF (DGICN'>0)
- QUIT
- +25 ;
- +26 ;ICN must not be local
- +27 IF $$IFLOCAL^MPIF001(DGDFN)
- QUIT
- +28 ;
- +29 SET DGRSLT=1
- End DoDot:1
- +30 QUIT DGRSLT
- +31 ;
- GETNXTF(DGDFN,DGLTF) ;get previous treating facility
- +1 ;This function will return the treating facility with a DATE LAST
- +2 ;TREATED value immediately prior to the date for the treating facility
- +3 ;passed as the second parameter. The most recent treating facility
- +4 ;will be returned when the second parameter is missing, null, or zero.
- +5 ;
- +6 ; Input:
- +7 ; DGDFN - pointer to patient in PATIENT (#2) file
- +8 ; DGLTF - (optional) last treating facility [default=0]
- +9 ;
- +10 ; Output:
- +11 ; Function value - previous facility as a pointer to INSTITUTION (#4)
- +12 ; file on success; 0 on failure
- +13 ;
- +14 ;fully subscripted array node
- NEW DGARR
- +15 ;date sorted treating facilities
- NEW DGDARR
- +16 ;institution pointer
- NEW DGINST
- +17 ;name of sorted treating facilities array
- NEW DGNAM
- +18 ;array of non-local treating facilities
- NEW DGTFARR
- +19 ;
- +20 ;
- +21 IF $GET(DGDFN)>0
- IF $$BLDTFL^DGPFUT2(DGDFN,.DGTFARR)
- Begin DoDot:1
- +22 ;
- +23 ;validate last treating facility input parameter
- +24 SET DGLTF=+$GET(DGLTF)
- +25 SET DGLTF=$SELECT(DGLTF&($DATA(DGTFARR(DGLTF))):DGLTF,1:0)
- +26 ;
- +27 ;build date sorted list
- +28 SET DGINST=0
- +29 FOR
- SET DGINST=$ORDER(DGTFARR(DGINST))
- IF 'DGINST
- QUIT
- Begin DoDot:2
- +30 SET DGDARR(DGTFARR(DGINST),DGINST)=""
- End DoDot:2
- +31 ;
- +32 ;find entry for previous treating facility
- +33 SET DGNAM="DGDARR"
- +34 SET DGARR=$QUERY(@DGNAM@(""),-1)
- +35 IF DGLTF
- IF DGARR]""
- Begin DoDot:2
- +36 IF $QSUBSCRIPT(DGARR,2)'=DGLTF
- Begin DoDot:3
- +37 FOR
- SET DGARR=$QUERY(@DGARR,-1)
- IF +$QSUBSCRIPT(DGARR,2)=DGLTF
- QUIT
- End DoDot:3
- +38 SET DGARR=$QUERY(@DGARR,-1)
- End DoDot:2
- End DoDot:1
- +39 ;
- +40 QUIT $SELECT($GET(DGARR)]"":+$QSUBSCRIPT(DGARR,2),1:0)
- +41 ;
- ISDIV(DGSITE) ;is site local division
- +1 ;
- +2 ; Input:
- +3 ; DGSITE - pointer to INSTITUTION (#4) file
- +4 ;
- +5 ; Output:
- +6 ; Function value - 1 on success; 0 on failure
- +7 ;
- +8 SET DGSITE=+$GET(DGSITE)
- +9 QUIT $SELECT($DATA(^DG(40.8,"AD",DGSITE)):1,1:0)