BPSOSSG.m

BPSOSSG ;BHAM ISC/SD/lwj/FLS - Special gets for formats ;06/01/2004

 ;;1.0;E CLAIMS MGMT ENGINE;**1,5,10,11,20,24,28**;JUN 2004;Build 22

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

 ;

 Q

 ;

FLD420 ; Submission Clarification Code

 ; place fields 354 and 420 into BPS CLAIMS

 ; called by SET CODE in BPS NCPDPD FIELD DEFS for field 420

 ;

 Q:'$G(BPS(9002313.0201))  ; must have entry IEN

 ;

 N BPSCNTR,CNT,FDA,MSG,FLDIEN,SCC,I

 K BPS(9002313.0354)  ; results from UPDATE^DIE

 S FLDIEN=$O(^BPSF(9002313.91,"B",420,""))  ;Get IEN for field 420 from NCPDP BPS FIELD DEFS

 ; Are there overrides?

 I $G(FLDIEN),$D(BPS("OVERRIDE","RX",BPS(9002313.0201),FLDIEN)) D

 . K BPS("RX",BPS(9002313.0201),"Submission Clarif Code")

 . S SCC=BPS("OVERRIDE","RX",BPS(9002313.0201),FLDIEN)

 . F I=1:1:3 S BPS("RX",BPS(9002313.0201),"Submission Clarif Code",I)=$P(SCC,"~",I)

 Q:'$O(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",0))  ; no values found

 S (CNT,BPSCNTR)=0

 F  S CNT=$O(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT)) Q:'CNT  D

 .I BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT)="" Q

 .S BPSCNTR=BPSCNTR+1  ; ien for (#354.01) SUBMISSION CLARIFICATION MLTPL

 .S FDA(9002313.02354,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",.01)=BPSCNTR

 .; 420-DK Submission Clarification Code

 .S FDA(9002313.02354,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",420)="DK"_$$NFF^BPSECFM(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT),2)

 ;

 I BPSCNTR D UPDATE^DIE("","FDA","BPS(9002313.0354)","MSG")

 I $D(MSG) D  Q  ; if error, log it and quit

 .D LOG2CLM^BPSOSL(BPS(9002313.02),$T(+0)_"-Failed to update NCPDP field 420")

 .D LOGARAY2^BPSOSL(BPS(9002313.02),"MSG")

 ;

 ; 354-NX Submission Clarification Code Count

 I BPSCNTR S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),350),U,4)="NX"_$$NFF^BPSECFM(BPSCNTR,1)

 ;

 Q

 ;

FLD439 ;Reason for service code

 ;Called by SET logic in BPS NCPDP Field DEFS for field 439

 ;DUR is newed/set in BPSOSHF

 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,2)=BPS("X")

 Q

 ;

FLD440 ;Professional Service Code

 ;Called by set logic in BPS NCPDP Field DEFS for field 440

 ;DUR is newed/set in BPSOSHF

 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,3)=BPS("X")

 Q

 ;

FLD441 ;Result of Service Code

 ;Called by SET logic in BPS NCPDP Field DEFS for field 441

 ;DUR is newed/set in BPSOSHF

 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,4)=BPS("X")

 Q

 ;

FLD473 ;DUR/PPS code counter - called from SET logic in BPS NCPDP Field Defs

 ;DUR is newed/set in BPSOSHF

 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,1)=BPS("X")

 S ^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,"B",BPS("X"),DUR)=""

 S ^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,0)="^9002313.1001A^"_DUR_"^"_DUR

 Q

 ;

FLD474 ;DUR/PPS level of effort - called from set logic in BPS NCPDP Field

 ;DUR is newed/set in BPSOSHF

 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,5)=BPS("X")

 Q

 ;

FLD475 ;DUR Co-agent ID Qualifier - called from set logic in BPS NCPDP Field

 ;DUR is newed/set in BPSOSHF

 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,6)=""

 Q

 ;

FLD476 ;DUR Co-agent ID - called from set logic in BPS NCPDP Field

 ;DUR is newed/set in BPSOSHF

 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,7)=""

 Q

 ;

FLD480 ; Other Amount Claimed Submitted field

 ; Called by set logic in BPS NCPDP Field DEFS for field 480

 ; Sets fields 478, 479, and 480 into BPS Claims

 ;   478-H7 Other Amount Claimed Count

 ;   479-H8 Other Amount Claimed Submitted Qualifier

 ;   480-H9 Other Amount Claimed Submitted

 ;

 Q:'$G(BPS(9002313.02))    ; must have BPS Claims IEN

 Q:'$G(BPS(9002313.0201))  ; must have Transaction subfile IEN

 Q:'$O(BPS("RX",BPS(9002313.0201),"Other Amt Value",0))  ; nothing to do

 ;

 N BPSCNTR,CNT,FDA,MSG

 K BPS(9002313.0601)  ; results from UPDATE^DIE

 S (CNT,BPSCNTR)=0

 F  S CNT=$O(BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT)) Q:'CNT  D

 . I +BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT)=0 Q

 . S BPSCNTR=BPSCNTR+1  ; ien for "PRICING REPEATING FIELDS SUB-FIELD^^480^3"

 . S FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",.01)=BPSCNTR

 . S FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",479)="H8"_$$ANFF^BPSECFM($G(BPS("RX",BPS(9002313.0201),"Other Amt Qual",CNT)),2)

 . S FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",480)="H9"_$$DFF^BPSECFM($G(BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT)),8)

 ;

 I BPSCNTR D UPDATE^DIE("","FDA","BPS(9002313.0601)","MSG")

 I $D(MSG) D  Q

 . D LOG2CLM^BPSOSL(BPS(9002313.02),$T(+0)_"-Failed to update NCPDP field 480 and/or 479")

 . D LOGARAY2^BPSOSL(BPS(9002313.02),"MSG")

 ; 478-H7 Other Amount Claimed Submitted Count

 I BPSCNTR S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),470),U,8)="H7"_$$NFF^BPSECFM(BPSCNTR,1)

 ;

 Q

 ;

FLDD02 ; Total Prescribed Quantity Remaining field (D02-KW)

 ; called by SET CODE in BPS NCPDP Field DEFS for field 2202 (D02-KW)

 ;

 I '$G(BPS(9002313.02)) S BPS(9002313.02)=$G(BPS02)

 Q:'$G(BPS(9002313.02))    ; must have BPS Claims IEN

 Q:'$G(BPS(9002313.0201))  ; must have Transaction subfile IEN

 ;

 N I,PREVFILLS,REFILLS,RTS,RXIEN,TOTALDISP,TOTALQTY,QTY

 ;

 S REFILLS=$G(BPS("RX",BPS(9002313.0201),"# Refills"))

 S QTY=$G(BPS("RX",BPS(9002313.0201),"Quantity"))

 S TOTALQTY=QTY*(REFILLS+1)  ; Total quantity for the prescription

 S PREVFILLS=$G(BPS("RX",BPS(9002313.0201),"Refill #"))

 ;

 ; Determine if any previous fills were returned to stock.

 S RXIEN=$G(BPS("RX",BPS(9002313.0201),"RX IEN"))

 S RTS=0

 I RXIEN S I=0 D

 . F  S I=$O(^PSRX(RXIEN,"RTS",I)) Q:'I  S RTS=RTS+1

 ;

 ; Subtract and return to stock fills (RTS) from the number of previous fills (PREVFILLS).

 S TOTALDISP=(PREVFILLS-RTS)*QTY  ; Total dispensed for all previous fills

 ; D02-KW Total Prescribed Quantity Remaining

 S BPS("X")=TOTALQTY-TOTALDISP

 S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),"D00"),U,2)="KW"_$$NFF^BPSECFM(BPS("X"),10)

 Q

 ;

EMPL ;Get employer info

 ; This by GET logic in BPS NCPDP Field Defs for field 315 (Employer Name)

 ; DMB 11/13/2006 - It makes some sense to only set these fields if

 ;   they exist on the payer sheet.  However, it assumes that the

 ;   employer name field will always be before the other fields and

 ;   that the other fields will not exist without the Employer Name

 ;   field.  For now, leave this be as these fields are on the

 ;   Worker's Comp segment, which we do not do.  We may want to evaluate

 ;   if we were to ever add the Worker's Comp segment

 Q:'$G(BPS("Patient","IEN"))

 D GETS^DIQ(2,BPS("Patient","IEN"),".3111;.3112;.3113;.3115;.3116;.3117;.3118;.3119","","EMPL")

 S BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3111)

 S:EMPL(2,BPS("Patient","IEN")_",",.3111)=""&(EMPL(2,BPS("Patient","IEN")_",",.3112)'="") BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3112)

 S BPS("Employer","Address")=EMPL(2,BPS("Patient","IEN")_",",.3113)

 S BPS("Employer","City")=EMPL(2,BPS("Patient","IEN")_",",.3116)

 S BPS("Employer","State")=EMPL(2,BPS("Patient","IEN")_",",.3117)

 I BPS("Employer","State")'="" D

 . S STATEIEN="",STATEIEN=$O(^DIC(5,"B",BPS("Employer","State"),STATEIEN)),BPS("Employer","State")=$P($G(^DIC(5,STATEIEN,0)),"^",2)

 S BPS("Employer","Zip Code")=EMPL(2,BPS("Patient","IEN")_",",.3118)

 S BPS("Employer","Phone")=EMPL(2,BPS("Patient","IEN")_",",.3119)

 K EMPL,STATEIEN

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---BPSOSSG   7686     printed  Mar 13, 2025@20:56:47                                                                                                                                                                                                     Page 2

BPSOSSG   ;BHAM ISC/SD/lwj/FLS - Special gets for formats ;06/01/2004

 +1       ;;1.0;E CLAIMS MGMT ENGINE;**1,5,10,11,20,24,28**;JUN 2004;Build 22

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

 +3       ;

 +4        QUIT 

 +5       ;

FLD420    ; Submission Clarification Code

 +1       ; place fields 354 and 420 into BPS CLAIMS

 +2       ; called by SET CODE in BPS NCPDPD FIELD DEFS for field 420

 +3       ;

 +4       ; must have entry IEN

           if '$GET(BPS(9002313.0201))

               QUIT 

 +5       ;

 +6        NEW BPSCNTR,CNT,FDA,MSG,FLDIEN,SCC,I

 +7       ; results from UPDATE^DIE

           KILL BPS(9002313.0354)

 +8       ;Get IEN for field 420 from NCPDP BPS FIELD DEFS

           SET FLDIEN=$ORDER(^BPSF(9002313.91,"B",420,""))

 +9       ; Are there overrides?

 +10       IF $GET(FLDIEN)

               IF $DATA(BPS("OVERRIDE","RX",BPS(9002313.0201),FLDIEN))

                   Begin DoDot:1

 +11                   KILL BPS("RX",BPS(9002313.0201),"Submission Clarif Code")

 +12                   SET SCC=BPS("OVERRIDE","RX",BPS(9002313.0201),FLDIEN)

 +13                   FOR I=1:1:3

                           SET BPS("RX",BPS(9002313.0201),"Submission Clarif Code",I)=$PIECE(SCC,"~",I)

                   End DoDot:1

 +14      ; no values found

           if '$ORDER(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",0))

               QUIT 

 +15       SET (CNT,BPSCNTR)=0

 +16       FOR 

               SET CNT=$ORDER(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT))

               if 'CNT

                   QUIT 

               Begin DoDot:1

 +17               IF BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT)=""

                       QUIT 

 +18      ; ien for (#354.01) SUBMISSION CLARIFICATION MLTPL

                   SET BPSCNTR=BPSCNTR+1

 +19               SET FDA(9002313.02354,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",.01)=BPSCNTR

 +20      ; 420-DK Submission Clarification Code

 +21               SET FDA(9002313.02354,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",420)="DK"_$$NFF^BPSECFM(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT),2)

               End DoDot:1

 +22      ;

 +23       IF BPSCNTR

               DO UPDATE^DIE("","FDA","BPS(9002313.0354)","MSG")

 +24      ; if error, log it and quit

           IF $DATA(MSG)

               Begin DoDot:1

 +25               DO LOG2CLM^BPSOSL(BPS(9002313.02),$TEXT(+0)_"-Failed to update NCPDP field 420")

 +26               DO LOGARAY2^BPSOSL(BPS(9002313.02),"MSG")

               End DoDot:1

               QUIT 

 +27      ;

 +28      ; 354-NX Submission Clarification Code Count

 +29       IF BPSCNTR

               SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),350),U,4)="NX"_$$NFF^BPSECFM(BPSCNTR,1)

 +30      ;

 +31       QUIT 

 +32      ;

FLD439    ;Reason for service code

 +1       ;Called by SET logic in BPS NCPDP Field DEFS for field 439

 +2       ;DUR is newed/set in BPSOSHF

 +3        SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,2)=BPS("X")

 +4        QUIT 

 +5       ;

FLD440    ;Professional Service Code

 +1       ;Called by set logic in BPS NCPDP Field DEFS for field 440

 +2       ;DUR is newed/set in BPSOSHF

 +3        SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,3)=BPS("X")

 +4        QUIT 

 +5       ;

FLD441    ;Result of Service Code

 +1       ;Called by SET logic in BPS NCPDP Field DEFS for field 441

 +2       ;DUR is newed/set in BPSOSHF

 +3        SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,4)=BPS("X")

 +4        QUIT 

 +5       ;

FLD473    ;DUR/PPS code counter - called from SET logic in BPS NCPDP Field Defs

 +1       ;DUR is newed/set in BPSOSHF

 +2        SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,1)=BPS("X")

 +3        SET ^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,"B",BPS("X"),DUR)=""

 +4        SET ^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,0)="^9002313.1001A^"_DUR_"^"_DUR

 +5        QUIT 

 +6       ;

FLD474    ;DUR/PPS level of effort - called from set logic in BPS NCPDP Field

 +1       ;DUR is newed/set in BPSOSHF

 +2        SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,5)=BPS("X")

 +3        QUIT 

 +4       ;

FLD475    ;DUR Co-agent ID Qualifier - called from set logic in BPS NCPDP Field

 +1       ;DUR is newed/set in BPSOSHF

 +2        SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,6)=""

 +3        QUIT 

 +4       ;

FLD476    ;DUR Co-agent ID - called from set logic in BPS NCPDP Field

 +1       ;DUR is newed/set in BPSOSHF

 +2        SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,7)=""

 +3        QUIT 

 +4       ;

FLD480    ; Other Amount Claimed Submitted field

 +1       ; Called by set logic in BPS NCPDP Field DEFS for field 480

 +2       ; Sets fields 478, 479, and 480 into BPS Claims

 +3       ;   478-H7 Other Amount Claimed Count

 +4       ;   479-H8 Other Amount Claimed Submitted Qualifier

 +5       ;   480-H9 Other Amount Claimed Submitted

 +6       ;

 +7       ; must have BPS Claims IEN

           if '$GET(BPS(9002313.02))

               QUIT 

 +8       ; must have Transaction subfile IEN

           if '$GET(BPS(9002313.0201))

               QUIT 

 +9       ; nothing to do

           if '$ORDER(BPS("RX",BPS(9002313.0201),"Other Amt Value",0))

               QUIT 

 +10      ;

 +11       NEW BPSCNTR,CNT,FDA,MSG

 +12      ; results from UPDATE^DIE

           KILL BPS(9002313.0601)

 +13       SET (CNT,BPSCNTR)=0

 +14       FOR 

               SET CNT=$ORDER(BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT))

               if 'CNT

                   QUIT 

               Begin DoDot:1

 +15               IF +BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT)=0

                       QUIT 

 +16      ; ien for "PRICING REPEATING FIELDS SUB-FIELD^^480^3"

                   SET BPSCNTR=BPSCNTR+1

 +17               SET FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",.01)=BPSCNTR

 +18               SET FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",479)="H8"_$$ANFF^BPSECFM($GET(BPS("RX",BPS(9002313.0201),"Other Amt Qual",CNT)),2)

 +19               SET FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",480)="H9"_$$DFF^BPSECFM($GET(BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT)),8)

               End DoDot:1

 +20      ;

 +21       IF BPSCNTR

               DO UPDATE^DIE("","FDA","BPS(9002313.0601)","MSG")

 +22       IF $DATA(MSG)

               Begin DoDot:1

 +23               DO LOG2CLM^BPSOSL(BPS(9002313.02),$TEXT(+0)_"-Failed to update NCPDP field 480 and/or 479")

 +24               DO LOGARAY2^BPSOSL(BPS(9002313.02),"MSG")

               End DoDot:1

               QUIT 

 +25      ; 478-H7 Other Amount Claimed Submitted Count

 +26       IF BPSCNTR

               SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),470),U,8)="H7"_$$NFF^BPSECFM(BPSCNTR,1)

 +27      ;

 +28       QUIT 

 +29      ;

FLDD02    ; Total Prescribed Quantity Remaining field (D02-KW)

 +1       ; called by SET CODE in BPS NCPDP Field DEFS for field 2202 (D02-KW)

 +2       ;

 +3        IF '$GET(BPS(9002313.02))

               SET BPS(9002313.02)=$GET(BPS02)

 +4       ; must have BPS Claims IEN

           if '$GET(BPS(9002313.02))

               QUIT 

 +5       ; must have Transaction subfile IEN

           if '$GET(BPS(9002313.0201))

               QUIT 

 +6       ;

 +7        NEW I,PREVFILLS,REFILLS,RTS,RXIEN,TOTALDISP,TOTALQTY,QTY

 +8       ;

 +9        SET REFILLS=$GET(BPS("RX",BPS(9002313.0201),"# Refills"))

 +10       SET QTY=$GET(BPS("RX",BPS(9002313.0201),"Quantity"))

 +11      ; Total quantity for the prescription

           SET TOTALQTY=QTY*(REFILLS+1)

 +12       SET PREVFILLS=$GET(BPS("RX",BPS(9002313.0201),"Refill #"))

 +13      ;

 +14      ; Determine if any previous fills were returned to stock.

 +15       SET RXIEN=$GET(BPS("RX",BPS(9002313.0201),"RX IEN"))

 +16       SET RTS=0

 +17       IF RXIEN

               SET I=0

               Begin DoDot:1

 +18               FOR 

                       SET I=$ORDER(^PSRX(RXIEN,"RTS",I))

                       if 'I

                           QUIT 

                       SET RTS=RTS+1

               End DoDot:1

 +19      ;

 +20      ; Subtract and return to stock fills (RTS) from the number of previous fills (PREVFILLS).

 +21      ; Total dispensed for all previous fills

           SET TOTALDISP=(PREVFILLS-RTS)*QTY

 +22      ; D02-KW Total Prescribed Quantity Remaining

 +23       SET BPS("X")=TOTALQTY-TOTALDISP

 +24       SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),"D00"),U,2)="KW"_$$NFF^BPSECFM(BPS("X"),10)

 +25       QUIT 

 +26      ;

EMPL      ;Get employer info

 +1       ; This by GET logic in BPS NCPDP Field Defs for field 315 (Employer Name)

 +2       ; DMB 11/13/2006 - It makes some sense to only set these fields if

 +3       ;   they exist on the payer sheet.  However, it assumes that the

 +4       ;   employer name field will always be before the other fields and

 +5       ;   that the other fields will not exist without the Employer Name

 +6       ;   field.  For now, leave this be as these fields are on the

 +7       ;   Worker's Comp segment, which we do not do.  We may want to evaluate

 +8       ;   if we were to ever add the Worker's Comp segment

 +9        if '$GET(BPS("Patient","IEN"))

               QUIT 

 +10       DO GETS^DIQ(2,BPS("Patient","IEN"),".3111;.3112;.3113;.3115;.3116;.3117;.3118;.3119","","EMPL")

 +11       SET BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3111)

 +12       if EMPL(2,BPS("Patient","IEN")_",",.3111)=""&(EMPL(2,BPS("Patient","IEN")_",",.3112)'="")

               SET BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3112)

 +13       SET BPS("Employer","Address")=EMPL(2,BPS("Patient","IEN")_",",.3113)

 +14       SET BPS("Employer","City")=EMPL(2,BPS("Patient","IEN")_",",.3116)

 +15       SET BPS("Employer","State")=EMPL(2,BPS("Patient","IEN")_",",.3117)

 +16       IF BPS("Employer","State")'=""

               Begin DoDot:1

 +17               SET STATEIEN=""

                   SET STATEIEN=$ORDER(^DIC(5,"B",BPS("Employer","State"),STATEIEN))

                   SET BPS("Employer","State")=$PIECE($GET(^DIC(5,STATEIEN,0)),"^",2)

               End DoDot:1

 +18       SET BPS("Employer","Zip Code")=EMPL(2,BPS("Patient","IEN")_",",.3118)

 +19       SET BPS("Employer","Phone")=EMPL(2,BPS("Patient","IEN")_",",.3119)

 +20       KILL EMPL,STATEIEN

 +21       QUIT 

 +22      ;