VAFHLRO2 ;BP/JRP - BUILD OUTPATIENT HL7 ROLE SEGMENT;11/18/1997 ; 7/3/01 4:09pm
;;5.3;Registration;**160,215,389**;Aug 13, 1993
;
; ** Do not call this routine directly **
; ** Use supported call OUTPAT^VAFHLROL **
;
OUTPAT ;Build role segment for transmission of outpatient data
;
;Input : As defined in OUTPAT^VAFHLROL
;Output : As defined in OUTPAT^VAFHLROL
;Notes : Existance & validity of input assumed
; : Refer to OUTPAT^VAFHLROL for details
;
;Declare variables
N PTR200,CODEONLY,INSTID,ACTION,ROLE,ALTROLE,PERSON,TMP,RDATE
N VAFHLROL,CMPSEP,REPSEP,ESCSEP,SUBSEP
;Break out individual seperators from encoding characters
S CMPSEP=$E(ENCODE,1)
S REPSEP=$E(ENCODE,2)
S ESCSEP=$E(ENCODE,3)
S SUBSEP=$E(ENCODE,4)
;Initialize output array
K @OUTARR S @OUTARR@(0)=""
;Get pointer to provider out of parameter array
S PTR200=+$G(@PARAM@("PTR200"))
S:('$D(^VA(200,PTR200,0))) PTR200=0
;Get internal/external flag
S CODEONLY=+$G(@PARAM@("CODEONLY"))
;Build segment into temporary location
S VAFHLROL(0)="ROL"
S1 ;Role Instance ID (seq #1)
S INSTID=$G(@PARAM@("INSTID"),NULL)
S TMP=$P(INSTID,CMPSEP,1)
D:((TMP=NULL)!(TMP="")) ERROR^VAFHLRO1(1,OUTARR,"could not be determined")
S VAFHLROL(1)=FLDSEP_INSTID
S2 ;Action Code (seq #2)
S ACTION=$G(@PARAM@("ACTION"),NULL)
S TMP=",AD,UP,DE,CO,LI,UN,UC,"
I (TMP'[(","_ACTION_",")) D
.I ((ACTION=NULL)!(ACTION="")) D ERROR^VAFHLRO1(2,OUTARR,"could not be determined") Q
.D ERROR^VAFHLRO1(2,OUTARR,"was not valid")
S VAFHLROL(2)=FLDSEP_ACTION
S3 ;Role (seq #3, comp #1 - 3)
I ($D(@PARAM@("ROLE"))) D G S3C4
.;Use input value
.S ROLE=$G(@PARAM@("ROLE"),NULL)
.I ((ROLE="")!(ROLE=NULL)) D ERROR^VAFHLRO1(3,OUTARR,"could not be determined")
.S TMP=$P(ROLE,CMPSEP,1)
.S:(TMP="") TMP=NULL
.S VAFHLROL(3,1)=FLDSEP_TMP
.S TMP=$P(ROLE,CMPSEP,2)
.S:(TMP="") TMP=NULL
.S VAFHLROL(3,2)=CMPSEP_TMP
.S TMP=$P(ROLE,CMPSEP,3)
.S:(TMP="") TMP=NULL
.S VAFHLROL(3,3)=CMPSEP_TMP
;Calculate value
I ('PTR200) D G S3C4
.D ERROR^VAFHLRO1(3,OUTARR,"could not be determined")
.S VAFHLROL(3)=FLDSEP_NULL_CMPSEP_NULL_CMPSEP_NULL
K ROLE S RDATE=$G(@PARAM@("RDATE"))
D ROLE^VAFHLRO3(PTR200,"ROLE",NULL,RDATE)
I ('$D(ROLE)) D G S3C4
.D ERROR^VAFHLRO1(3,OUTARR,"could not be determined")
.S VAFHLROL(3)=FLDSEP_NULL_CMPSEP_NULL_CMPSEP_NULL
;Strip out external values
I (CODEONLY) F TMP=1:1:3 S ROLE(2,TMP)=NULL
;Copy and add appropriate seperators
; (Convert any HL7 characters into spaces)
S TMP=FLDSEP_ENCODE
S VAFHLROL(3,1)=FLDSEP_$TR(ROLE(1),TMP," ")
S VAFHLROL(3,2,1)=CMPSEP_$TR(ROLE(2,1),TMP," ")
S VAFHLROL(3,2,2)=SUBSEP_$TR(ROLE(2,2),TMP," ")
S VAFHLROL(3,2,3)=SUBSEP_$TR(ROLE(2,3),TMP," ")
S VAFHLROL(3,3)=CMPSEP_$TR(ROLE(3),TMP," ")
S3C4 ;Alternate Role (seq #3, comp #4 - 6)
I ('$D(@PARAM@("ALTROLE"))) D G S4
.S VAFHLROL(3,4)=CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL
;Use input value
S TMP=NULL_CMPSEP_NULL_CMPSEP_NULL
S ALTROLE=$G(@PARAM@("ALTROLE"),TMP)
S:(ALTROLE="") ALTROLE=TMP
S TMP=$P(ALTROLE,CMPSEP,1)
S:(TMP="") TMP=NULL
S VAFHLROL(3,4)=CMPSEP_TMP
S TMP=$P(ALTROLE,CMPSEP,2)
S:(TMP="") TMP=NULL
S VAFHLROL(3,5)=CMPSEP_TMP
S TMP=$P(ALTROLE,CMPSEP,3)
S:(TMP="") TMP=NULL
S VAFHLROL(3,6)=CMPSEP_TMP
S4 ;Role Person (seq #4)
I ($D(@PARAM@("PERSON"))) D G DONE
.;Use input value
.S PERSON=$G(@PARAM@("PERSON"),NULL)
.I ((PERSON="")!(PERSON=NULL)) D ERROR^VAFHLRO1(4,OUTARR,"could not be determined")
.S TMP=$P(PERSON,CMPSEP,1)
.S:(TMP="") TMP=NULL
.S VAFHLROL(4,1)=FLDSEP_TMP
.S TMP=$P(PERSON,CMPSEP,2)
.S:(TMP="") TMP=NULL
.S VAFHLROL(4,2)=CMPSEP_TMP
.S TMP=$P(PERSON,CMPSEP,3)
.S:(TMP="") TMP=NULL
.S VAFHLROL(4,3)=CMPSEP_TMP
.S TMP=$P(PERSON,CMPSEP,4)
.S:(TMP="") TMP=NULL
.S VAFHLROL(4,4)=CMPSEP_TMP
.S TMP=$P(PERSON,CMPSEP,5)
.S:(TMP="") TMP=NULL
.S VAFHLROL(4,5)=CMPSEP_TMP
.S TMP=$P(PERSON,CMPSEP,6)
.S:(TMP="") TMP=NULL
.S VAFHLROL(4,6)=CMPSEP_TMP
.S TMP=$P(PERSON,CMPSEP,7)
.S:(TMP="") TMP=NULL
.S VAFHLROL(4,7)=CMPSEP_TMP
.S TMP=$P(PERSON,CMPSEP,8)
.S:(TMP="") TMP=NULL
.S VAFHLROL(4,8)=CMPSEP_TMP
;Calculate value
I ('PTR200) D G DONE
.D ERROR^VAFHLRO1(4,OUTARR,"could not be determined")
.S VAFHLROL(4)=FLDSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL
K PERSON D PERSON^VAFHLRO3(PTR200,"PERSON",NULL)
I ('$D(PERSON)) D G DONE
.D ERROR^VAFHLRO1(4,OUTARR,"could not be determined")
.S VAFHLROL(4)=FLDSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL
;Strip out external values
I (CODEONLY) F TMP=2:1:7 S PERSON(1,TMP)=NULL
;Copy and add appropriate seperators
; (Convert any HL7 characters into spaces)
S TMP=FLDSEP_ENCODE
S VAFHLROL(4,1,1,1)=FLDSEP_$TR(PERSON(1,1,1),TMP," ")
S VAFHLROL(4,1,1,2)=SUBSEP_$TR(PERSON(1,1,2),TMP," ")
S VAFHLROL(4,1,2)=CMPSEP_$TR(PERSON(1,2),TMP," ")
S VAFHLROL(4,1,3)=CMPSEP_$TR(PERSON(1,3),TMP," ")
S VAFHLROL(4,1,4)=CMPSEP_$TR(PERSON(1,4),TMP," ")
S VAFHLROL(4,1,5)=CMPSEP_$TR(PERSON(1,5),TMP," ")
S VAFHLROL(4,1,6)=CMPSEP_$TR(PERSON(1,6),TMP," ")
S VAFHLROL(4,1,7)=CMPSEP_$TR(PERSON(1,7),TMP," ")
S VAFHLROL(4,1,8)=CMPSEP_$TR(PERSON(1,8),TMP," ")
S VAFHLROL(4,2,1)=REPSEP_$TR(PERSON(2,1),TMP," ")
F TMP=1:1:7 S VAFHLROL(4,2,TMP+1)=CMPSEP_$TR(PERSON(2,TMP+1),TMP," ")
S VAFHLROL(4,2,9)=CMPSEP_$TR(PERSON(2,9),TMP," ")
DONE ;Collapse into output location
D FIXLEN^VAFHLRO1("VAFHLROL",OUTARR,MAXLEN,0)
;Done
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFHLRO2 5633 printed Oct 16, 2024@19:03:44 Page 2
VAFHLRO2 ;BP/JRP - BUILD OUTPATIENT HL7 ROLE SEGMENT;11/18/1997 ; 7/3/01 4:09pm
+1 ;;5.3;Registration;**160,215,389**;Aug 13, 1993
+2 ;
+3 ; ** Do not call this routine directly **
+4 ; ** Use supported call OUTPAT^VAFHLROL **
+5 ;
OUTPAT ;Build role segment for transmission of outpatient data
+1 ;
+2 ;Input : As defined in OUTPAT^VAFHLROL
+3 ;Output : As defined in OUTPAT^VAFHLROL
+4 ;Notes : Existance & validity of input assumed
+5 ; : Refer to OUTPAT^VAFHLROL for details
+6 ;
+7 ;Declare variables
+8 NEW PTR200,CODEONLY,INSTID,ACTION,ROLE,ALTROLE,PERSON,TMP,RDATE
+9 NEW VAFHLROL,CMPSEP,REPSEP,ESCSEP,SUBSEP
+10 ;Break out individual seperators from encoding characters
+11 SET CMPSEP=$EXTRACT(ENCODE,1)
+12 SET REPSEP=$EXTRACT(ENCODE,2)
+13 SET ESCSEP=$EXTRACT(ENCODE,3)
+14 SET SUBSEP=$EXTRACT(ENCODE,4)
+15 ;Initialize output array
+16 KILL @OUTARR
SET @OUTARR@(0)=""
+17 ;Get pointer to provider out of parameter array
+18 SET PTR200=+$GET(@PARAM@("PTR200"))
+19 if ('$DATA(^VA(200,PTR200,0)))
SET PTR200=0
+20 ;Get internal/external flag
+21 SET CODEONLY=+$GET(@PARAM@("CODEONLY"))
+22 ;Build segment into temporary location
+23 SET VAFHLROL(0)="ROL"
S1 ;Role Instance ID (seq #1)
+1 SET INSTID=$GET(@PARAM@("INSTID"),NULL)
+2 SET TMP=$PIECE(INSTID,CMPSEP,1)
+3 if ((TMP=NULL)!(TMP=""))
DO ERROR^VAFHLRO1(1,OUTARR,"could not be determined")
+4 SET VAFHLROL(1)=FLDSEP_INSTID
S2 ;Action Code (seq #2)
+1 SET ACTION=$GET(@PARAM@("ACTION"),NULL)
+2 SET TMP=",AD,UP,DE,CO,LI,UN,UC,"
+3 IF (TMP'[(","_ACTION_","))
Begin DoDot:1
+4 IF ((ACTION=NULL)!(ACTION=""))
DO ERROR^VAFHLRO1(2,OUTARR,"could not be determined")
QUIT
+5 DO ERROR^VAFHLRO1(2,OUTARR,"was not valid")
End DoDot:1
+6 SET VAFHLROL(2)=FLDSEP_ACTION
S3 ;Role (seq #3, comp #1 - 3)
+1 IF ($DATA(@PARAM@("ROLE")))
Begin DoDot:1
+2 ;Use input value
+3 SET ROLE=$GET(@PARAM@("ROLE"),NULL)
+4 IF ((ROLE="")!(ROLE=NULL))
DO ERROR^VAFHLRO1(3,OUTARR,"could not be determined")
+5 SET TMP=$PIECE(ROLE,CMPSEP,1)
+6 if (TMP="")
SET TMP=NULL
+7 SET VAFHLROL(3,1)=FLDSEP_TMP
+8 SET TMP=$PIECE(ROLE,CMPSEP,2)
+9 if (TMP="")
SET TMP=NULL
+10 SET VAFHLROL(3,2)=CMPSEP_TMP
+11 SET TMP=$PIECE(ROLE,CMPSEP,3)
+12 if (TMP="")
SET TMP=NULL
+13 SET VAFHLROL(3,3)=CMPSEP_TMP
End DoDot:1
GOTO S3C4
+14 ;Calculate value
+15 IF ('PTR200)
Begin DoDot:1
+16 DO ERROR^VAFHLRO1(3,OUTARR,"could not be determined")
+17 SET VAFHLROL(3)=FLDSEP_NULL_CMPSEP_NULL_CMPSEP_NULL
End DoDot:1
GOTO S3C4
+18 KILL ROLE
SET RDATE=$GET(@PARAM@("RDATE"))
+19 DO ROLE^VAFHLRO3(PTR200,"ROLE",NULL,RDATE)
+20 IF ('$DATA(ROLE))
Begin DoDot:1
+21 DO ERROR^VAFHLRO1(3,OUTARR,"could not be determined")
+22 SET VAFHLROL(3)=FLDSEP_NULL_CMPSEP_NULL_CMPSEP_NULL
End DoDot:1
GOTO S3C4
+23 ;Strip out external values
+24 IF (CODEONLY)
FOR TMP=1:1:3
SET ROLE(2,TMP)=NULL
+25 ;Copy and add appropriate seperators
+26 ; (Convert any HL7 characters into spaces)
+27 SET TMP=FLDSEP_ENCODE
+28 SET VAFHLROL(3,1)=FLDSEP_$TRANSLATE(ROLE(1),TMP," ")
+29 SET VAFHLROL(3,2,1)=CMPSEP_$TRANSLATE(ROLE(2,1),TMP," ")
+30 SET VAFHLROL(3,2,2)=SUBSEP_$TRANSLATE(ROLE(2,2),TMP," ")
+31 SET VAFHLROL(3,2,3)=SUBSEP_$TRANSLATE(ROLE(2,3),TMP," ")
+32 SET VAFHLROL(3,3)=CMPSEP_$TRANSLATE(ROLE(3),TMP," ")
S3C4 ;Alternate Role (seq #3, comp #4 - 6)
+1 IF ('$DATA(@PARAM@("ALTROLE")))
Begin DoDot:1
+2 SET VAFHLROL(3,4)=CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL
End DoDot:1
GOTO S4
+3 ;Use input value
+4 SET TMP=NULL_CMPSEP_NULL_CMPSEP_NULL
+5 SET ALTROLE=$GET(@PARAM@("ALTROLE"),TMP)
+6 if (ALTROLE="")
SET ALTROLE=TMP
+7 SET TMP=$PIECE(ALTROLE,CMPSEP,1)
+8 if (TMP="")
SET TMP=NULL
+9 SET VAFHLROL(3,4)=CMPSEP_TMP
+10 SET TMP=$PIECE(ALTROLE,CMPSEP,2)
+11 if (TMP="")
SET TMP=NULL
+12 SET VAFHLROL(3,5)=CMPSEP_TMP
+13 SET TMP=$PIECE(ALTROLE,CMPSEP,3)
+14 if (TMP="")
SET TMP=NULL
+15 SET VAFHLROL(3,6)=CMPSEP_TMP
S4 ;Role Person (seq #4)
+1 IF ($DATA(@PARAM@("PERSON")))
Begin DoDot:1
+2 ;Use input value
+3 SET PERSON=$GET(@PARAM@("PERSON"),NULL)
+4 IF ((PERSON="")!(PERSON=NULL))
DO ERROR^VAFHLRO1(4,OUTARR,"could not be determined")
+5 SET TMP=$PIECE(PERSON,CMPSEP,1)
+6 if (TMP="")
SET TMP=NULL
+7 SET VAFHLROL(4,1)=FLDSEP_TMP
+8 SET TMP=$PIECE(PERSON,CMPSEP,2)
+9 if (TMP="")
SET TMP=NULL
+10 SET VAFHLROL(4,2)=CMPSEP_TMP
+11 SET TMP=$PIECE(PERSON,CMPSEP,3)
+12 if (TMP="")
SET TMP=NULL
+13 SET VAFHLROL(4,3)=CMPSEP_TMP
+14 SET TMP=$PIECE(PERSON,CMPSEP,4)
+15 if (TMP="")
SET TMP=NULL
+16 SET VAFHLROL(4,4)=CMPSEP_TMP
+17 SET TMP=$PIECE(PERSON,CMPSEP,5)
+18 if (TMP="")
SET TMP=NULL
+19 SET VAFHLROL(4,5)=CMPSEP_TMP
+20 SET TMP=$PIECE(PERSON,CMPSEP,6)
+21 if (TMP="")
SET TMP=NULL
+22 SET VAFHLROL(4,6)=CMPSEP_TMP
+23 SET TMP=$PIECE(PERSON,CMPSEP,7)
+24 if (TMP="")
SET TMP=NULL
+25 SET VAFHLROL(4,7)=CMPSEP_TMP
+26 SET TMP=$PIECE(PERSON,CMPSEP,8)
+27 if (TMP="")
SET TMP=NULL
+28 SET VAFHLROL(4,8)=CMPSEP_TMP
End DoDot:1
GOTO DONE
+29 ;Calculate value
+30 IF ('PTR200)
Begin DoDot:1
+31 DO ERROR^VAFHLRO1(4,OUTARR,"could not be determined")
+32 SET VAFHLROL(4)=FLDSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL
End DoDot:1
GOTO DONE
+33 KILL PERSON
DO PERSON^VAFHLRO3(PTR200,"PERSON",NULL)
+34 IF ('$DATA(PERSON))
Begin DoDot:1
+35 DO ERROR^VAFHLRO1(4,OUTARR,"could not be determined")
+36 SET VAFHLROL(4)=FLDSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL_CMPSEP_NULL
End DoDot:1
GOTO DONE
+37 ;Strip out external values
+38 IF (CODEONLY)
FOR TMP=2:1:7
SET PERSON(1,TMP)=NULL
+39 ;Copy and add appropriate seperators
+40 ; (Convert any HL7 characters into spaces)
+41 SET TMP=FLDSEP_ENCODE
+42 SET VAFHLROL(4,1,1,1)=FLDSEP_$TRANSLATE(PERSON(1,1,1),TMP," ")
+43 SET VAFHLROL(4,1,1,2)=SUBSEP_$TRANSLATE(PERSON(1,1,2),TMP," ")
+44 SET VAFHLROL(4,1,2)=CMPSEP_$TRANSLATE(PERSON(1,2),TMP," ")
+45 SET VAFHLROL(4,1,3)=CMPSEP_$TRANSLATE(PERSON(1,3),TMP," ")
+46 SET VAFHLROL(4,1,4)=CMPSEP_$TRANSLATE(PERSON(1,4),TMP," ")
+47 SET VAFHLROL(4,1,5)=CMPSEP_$TRANSLATE(PERSON(1,5),TMP," ")
+48 SET VAFHLROL(4,1,6)=CMPSEP_$TRANSLATE(PERSON(1,6),TMP," ")
+49 SET VAFHLROL(4,1,7)=CMPSEP_$TRANSLATE(PERSON(1,7),TMP," ")
+50 SET VAFHLROL(4,1,8)=CMPSEP_$TRANSLATE(PERSON(1,8),TMP," ")
+51 SET VAFHLROL(4,2,1)=REPSEP_$TRANSLATE(PERSON(2,1),TMP," ")
+52 FOR TMP=1:1:7
SET VAFHLROL(4,2,TMP+1)=CMPSEP_$TRANSLATE(PERSON(2,TMP+1),TMP," ")
+53 SET VAFHLROL(4,2,9)=CMPSEP_$TRANSLATE(PERSON(2,9),TMP," ")
DONE ;Collapse into output location
+1 DO FIXLEN^VAFHLRO1("VAFHLROL",OUTARR,MAXLEN,0)
+2 ;Done
+3 QUIT
