- DGPFHLU1 ;ALB/RPM - PRF HL7 BUILD OBR SEGMENT ; 2/18/03
- ;;5.3;Registration;**425,951**;Aug 13, 1993;Build 135
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- Q
- ;
- OBR(DGSET,DGPFA,DGPFAH,DGFLD,DGHL) ;OBR Segment API
- ;This function wraps the data retrieval and segment creation APIs and
- ;returns a formatted OBR segment.
- ;
- ; Input:
- ; DGSET - (required) OBR segment Set ID
- ; DGPFA - (required) Assignment data array
- ; DGPFAH - (required) Assignment history data array
- ; DGFLD - (optional) List of comma-separated fields (sequence #'s)
- ; to include. Defaults to all required fields (4).
- ; DGHL - HL7 environment array
- ;
- ; Output:
- ; Function Value - OBR segment on success, "" on failure
- ;
- N DGOBR
- N DGVAL
- ;
- S HLECH=DGHL("ECH"),HLFS=DGHL("FS")
- S DGOBR=""
- I $G(DGSET)>0,$D(DGPFA),$D(DGPFAH) D
- . S DGFLD=$$CKSTR^DGPFHLUT("4",DGFLD) ;validate the field string
- . S DGFLD=","_DGFLD_","
- . I $$OBRVAL(DGFLD,DGSET,.DGPFA,.DGPFAH,.DGVAL) D
- . . S DGOBR=$$BLDSEG^DGPFHLUT("OBR",.DGVAL,.DGHL)
- Q DGOBR
- ;
- OBRVAL(DGFLD,DGSET,DGPFA,DGPFAH,DGVAL) ;build OBR value array
- ;
- ; Input:
- ; DGFLD - (required) Fields string
- ; DGSET - (required) OBR segment Set ID
- ; DGPFA - (required) Assignment data array
- ; DGPFAH - (required) Assignment history data array
- ;
- ; Output:
- ; Function Value - 1 on success, 0 on failure
- ; DGVAL - OBR field array [SUB1:field, SUB2:repetition,
- ; SUB3:component, SUB4:sub-component]
- ;
- N DGRSLT ;function value
- N DGADT ;assignment date
- N DGORIG ;originating site
- N DGOWN ;assignment owner
- ;
- S DGRSLT=0
- I $G(DGFLD)]"",+$G(DGSET)>0,+$G(DGPFA("FLAG"))>0,+$G(DGPFAH("ASSIGN"))>0 D
- .; seq 1 Set ID
- .I DGFLD[",1," S DGVAL(1)=DGSET
- .; seq 4 Universal Service ID
- .I DGFLD[",4," D ;required field
- ..S DGVAL(4,1,1)=+DGPFA("FLAG") ;flag ien
- ..S DGVAL(4,1,2)=$$ENCHL7^DGPFHLUT($P(DGPFA("FLAG"),U,2)) ;flag name
- ..S DGVAL(4,1,3)="VA085" ;table name
- ..Q
- .; seq 7 Observation Date/Time
- .I DGFLD[",7," D
- ..S DGADT=$$FMTHL7^XLFDT(+$$GETADT^DGPFAAH(+DGPFAH("ASSIGN")))
- ..S DGVAL(7)=$S(DGADT>0:DGADT,1:"")
- ..Q
- .; seq 20 Filler field 1
- .I DGFLD[",20," D
- ..S DGOWN=+$G(DGPFA("OWNER"))
- ..S DGVAL(20)=$S(DGOWN>0:$$STA^XUAF4(DGOWN),1:"")
- ..Q
- .; seq 21 Filler Field 2
- .I DGFLD[",21," D
- ..S DGORIG=+$G(DGPFA("ORIGSITE"))
- ..S DGVAL(21)=$S(DGORIG>0:$$STA^XUAF4(DGORIG),1:"")
- ..Q
- .S DGRSLT=1
- .Q
- I 'DGRSLT K DGVAL
- Q DGRSLT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLU1 2633 printed Feb 19, 2025@00:13:56 Page 2
- DGPFHLU1 ;ALB/RPM - PRF HL7 BUILD OBR SEGMENT ; 2/18/03
- +1 ;;5.3;Registration;**425,951**;Aug 13, 1993;Build 135
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 QUIT
- +5 ;
- OBR(DGSET,DGPFA,DGPFAH,DGFLD,DGHL) ;OBR Segment API
- +1 ;This function wraps the data retrieval and segment creation APIs and
- +2 ;returns a formatted OBR segment.
- +3 ;
- +4 ; Input:
- +5 ; DGSET - (required) OBR segment Set ID
- +6 ; DGPFA - (required) Assignment data array
- +7 ; DGPFAH - (required) Assignment history data array
- +8 ; DGFLD - (optional) List of comma-separated fields (sequence #'s)
- +9 ; to include. Defaults to all required fields (4).
- +10 ; DGHL - HL7 environment array
- +11 ;
- +12 ; Output:
- +13 ; Function Value - OBR segment on success, "" on failure
- +14 ;
- +15 NEW DGOBR
- +16 NEW DGVAL
- +17 ;
- +18 SET HLECH=DGHL("ECH")
- SET HLFS=DGHL("FS")
- +19 SET DGOBR=""
- +20 IF $GET(DGSET)>0
- IF $DATA(DGPFA)
- IF $DATA(DGPFAH)
- Begin DoDot:1
- +21 ;validate the field string
- SET DGFLD=$$CKSTR^DGPFHLUT("4",DGFLD)
- +22 SET DGFLD=","_DGFLD_","
- +23 IF $$OBRVAL(DGFLD,DGSET,.DGPFA,.DGPFAH,.DGVAL)
- Begin DoDot:2
- +24 SET DGOBR=$$BLDSEG^DGPFHLUT("OBR",.DGVAL,.DGHL)
- End DoDot:2
- End DoDot:1
- +25 QUIT DGOBR
- +26 ;
- OBRVAL(DGFLD,DGSET,DGPFA,DGPFAH,DGVAL) ;build OBR value array
- +1 ;
- +2 ; Input:
- +3 ; DGFLD - (required) Fields string
- +4 ; DGSET - (required) OBR segment Set ID
- +5 ; DGPFA - (required) Assignment data array
- +6 ; DGPFAH - (required) Assignment history data array
- +7 ;
- +8 ; Output:
- +9 ; Function Value - 1 on success, 0 on failure
- +10 ; DGVAL - OBR field array [SUB1:field, SUB2:repetition,
- +11 ; SUB3:component, SUB4:sub-component]
- +12 ;
- +13 ;function value
- NEW DGRSLT
- +14 ;assignment date
- NEW DGADT
- +15 ;originating site
- NEW DGORIG
- +16 ;assignment owner
- NEW DGOWN
- +17 ;
- +18 SET DGRSLT=0
- +19 IF $GET(DGFLD)]""
- IF +$GET(DGSET)>0
- IF +$GET(DGPFA("FLAG"))>0
- IF +$GET(DGPFAH("ASSIGN"))>0
- Begin DoDot:1
- +20 ; seq 1 Set ID
- +21 IF DGFLD[",1,"
- SET DGVAL(1)=DGSET
- +22 ; seq 4 Universal Service ID
- +23 ;required field
- IF DGFLD[",4,"
- Begin DoDot:2
- +24 ;flag ien
- SET DGVAL(4,1,1)=+DGPFA("FLAG")
- +25 ;flag name
- SET DGVAL(4,1,2)=$$ENCHL7^DGPFHLUT($PIECE(DGPFA("FLAG"),U,2))
- +26 ;table name
- SET DGVAL(4,1,3)="VA085"
- +27 QUIT
- End DoDot:2
- +28 ; seq 7 Observation Date/Time
- +29 IF DGFLD[",7,"
- Begin DoDot:2
- +30 SET DGADT=$$FMTHL7^XLFDT(+$$GETADT^DGPFAAH(+DGPFAH("ASSIGN")))
- +31 SET DGVAL(7)=$SELECT(DGADT>0:DGADT,1:"")
- +32 QUIT
- End DoDot:2
- +33 ; seq 20 Filler field 1
- +34 IF DGFLD[",20,"
- Begin DoDot:2
- +35 SET DGOWN=+$GET(DGPFA("OWNER"))
- +36 SET DGVAL(20)=$SELECT(DGOWN>0:$$STA^XUAF4(DGOWN),1:"")
- +37 QUIT
- End DoDot:2
- +38 ; seq 21 Filler Field 2
- +39 IF DGFLD[",21,"
- Begin DoDot:2
- +40 SET DGORIG=+$GET(DGPFA("ORIGSITE"))
- +41 SET DGVAL(21)=$SELECT(DGORIG>0:$$STA^XUAF4(DGORIG),1:"")
- +42 QUIT
- End DoDot:2
- +43 SET DGRSLT=1
- +44 QUIT
- End DoDot:1
- +45 IF 'DGRSLT
- KILL DGVAL
- +46 QUIT DGRSLT