- BPSJVAL2 ;BHAM ISC/LJF - Validate Pharmacy data ;3/5/08 11:14
- ;;1.0;E CLAIMS MGMT ENGINE;**1,2,5,7**;JUN 2004;Build 46
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- N PHARMIX,RET,DIR,X
- ;
- S PHARMIX=0,X=""
- F S PHARMIX=$O(^BPS(9002313.56,PHARMIX)) Q:'PHARMIX D Q:X=U
- . W !!,"VERIFY PHARMACY REGISTRATIONS DATA.",!
- . D REG^BPSJPREG(PHARMIX,2)
- . W !
- . S DIR(0)="EO" D ^DIR
- ;
- Q
- ;
- ; Array HL and variable VERBOSE newed/set by calling routine
- ; RETCODE returned to calling routine
- VALIDATE(BPSJDDD) ;
- N SEG,SEGIX,ZRP,RAY,RIX,PIX,PIXL,SEGDAT,ZNOTE,ZMAX,CPS,FS,REP
- N VALDATA,TMP
- S ZMAX=17
- ;
- S RETCODE=$G(RETCODE)
- S ZRP="",RIX=0
- ;
- ; Set HL7 Delimiters - use standard defaults if none provided
- S FS=$G(HL("FS")) I FS="" S FS="|"
- S CPS=$E($G(HL("ECH"))) I CPS="" S CPS="^"
- S REP=$E($G(HL("ECH")),2) I REP="" S REP="~"
- ;
- F SEGIX=3:1 S SEG=$G(^TMP("HLS",$J,SEGIX)),PIX=0 Q:SEG="" D I ZRP]"" Q
- . I $E(SEG,1,3)="ZRP" S ZRP=$E(SEG,4) S $E(SEG,1,4)=""
- I ZRP="" Q
- F S RIX=$O(^TMP("HLS",$J,SEGIX,RIX)) Q:'RIX I RIX<(ZMAX+1) D
- . S TMP=$P($G(^TMP("HLS",$J,SEGIX,RIX)),ZRP)
- . I $G(TMP)="" S RETCODE(RIX)=""
- . I RIX=3 S RETCODE(RIX)=TMP ;capture pharmacy name
- F S RIX=$O(RETCODE(RIX)) Q:'RIX D
- . D @RIX
- . I +$G(VERBOSE),$L($G(RETCODE(RIX))) W !,RETCODE(RIX)
- ;
- Q
- ;
- ; NS=Not Supported, R=Required, RE=Required or empty, C=Conditional
- ; CE=Conditional or empty, O=Optional,
- ;
- 1 ; Set ID - NS
- Q
- 2 ; NCPDP Number - C
- S ZNOTE=" NCPDP NUMBER - VALID"
- I RETCODE(RIX)="" D
- . I BPSJDDD=0 D
- . . I '$D(RETCODE(17)) Q
- . . S ZNOTE="** NCPDP NUMBER - NCPDP OR NPI - Missing/Invalid",RETCODE=2
- . . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- Q
- 3 ; PHARMACY NAME - R
- S ZNOTE=" PHARMACY NAME"
- I RETCODE(RIX)="" D
- . S ZNOTE="** PHARMACY NAME - Missing/Invalid",RETCODE=3
- I RETCODE(RIX)]"" S RETCODE(RIX)=": "_$$DECODE(RETCODE(RIX))
- S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- Q
- 4 ; DEA Number - R
- S ZNOTE=" DEA NUMBER - Required - VALID"
- I RETCODE(RIX)="" D
- . S ZNOTE="** DEA NUMBER - Missing/Invalid",RETCODE=4
- . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- Q
- 5 ; Hour of Operation
- S ZNOTE="" ; not sending anymore
- Q
- 6 ; Mailing Address - R
- S ZNOTE=$$TRIMTAIL(RETCODE(RIX))
- S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Street address
- S VALDATA=($L($P(ZNOTE,CPS,3))<1)+VALDATA ; City
- S VALDATA=($L($P(ZNOTE,CPS,4))<1)+VALDATA ; State
- S VALDATA=($L($P(ZNOTE,CPS,5))<1)+VALDATA ; Zip
- S ZNOTE=" MAILING ADDRESS - Required - VALID"
- I VALDATA D
- . S ZNOTE="** MAILING ADDRESS - Missing/Invalid",RETCODE=6
- . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- Q
- 7 ; Remittance Address - R
- S ZNOTE=$$TRIMTAIL(RETCODE(RIX))
- S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Street Address
- S VALDATA=($L($P(ZNOTE,CPS,3))<1)+VALDATA ; City
- S VALDATA=($L($P(ZNOTE,CPS,4))<1)+VALDATA ; State
- S VALDATA=($L($P(ZNOTE,CPS,5))<1)+VALDATA ; Zip
- S ZNOTE=" REMITTANCE ADDRESS - Required - VALID"
- I VALDATA D
- . S ZNOTE="** REMITTANCE ADDRESS - Missing/Invalid",RETCODE=7
- . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- Q
- 8 ; Contact Name
- S ZNOTE=$$TRIMTAIL(RETCODE(RIX))
- S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Surname
- S ZNOTE=" CONTACT NAME - Required - VALID"
- I VALDATA D
- . S ZNOTE="** CONTACT NAME - Missing/Invalid",RETCODE=8
- . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- Q
- 9 ; Contact Title
- S ZNOTE=" CONTACT TITLE - VALID"
- Q
- 10 ; Contact means
- S ZNOTE=" CONTACT MEANS - VALID"
- ;S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- Q
- 11 ; Alternate Contact Name
- S ZNOTE=$$TRIMTAIL(RETCODE(RIX))
- S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Surname
- S ZNOTE=" ALTERNATE CONTACT NAME - Required - VALID"
- I VALDATA D
- . S ZNOTE="** ALTERNATE CONTACT NAME - Missing/Invalid",RETCODE=11
- . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- Q
- 12 ; Alternate Contact Title
- S ZNOTE=" ALTERNATE CONTACT TITLE - VALID"
- Q
- 13 ; Alternate Contact means
- S ZNOTE=" ALTERNATE CONTACT MEANS - VALID"
- Q
- 14 ; Lead Pharmacist Name - R
- S ZNOTE=$$TRIMTAIL(RETCODE(RIX))
- S VALDATA=($L($P(ZNOTE,CPS,1))<1) ; Surname
- S ZNOTE=" LEAD PHARMACIST NAME - Required - VALID"
- I VALDATA D
- . S ZNOTE="** LEAD PHARMACIST NAME - Missing/Invalid",RETCODE=14
- . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- Q
- 15 ; Lead Pharmacist Title
- S ZNOTE=" LEAD PHARMACIST TITLE - VALID"
- Q
- 16 ; Lead Pharmacist License Number
- S ZNOTE=" LEAD PHARMACIST LICENSE NUMBER - VALID"
- Q
- 17 ; NPI Number - C (R - AFTER DDD)
- S ZNOTE=" NPI NUMBER - Required - VALID "
- I RETCODE(RIX)="" D
- . I BPSJDDD=0 D
- . . I '$D(RETCODE(2)) S ZNOTE=" NPI NUMBER - Warning NPI NUMBER Missing " Q
- . . S ZNOTE="** NPI NUMBER - NPI OR NCPDP - Missing/Invalid" S RETCODE=17
- . I BPSJDDD>0 D
- . . S ZNOTE="** NPI NUMBER - Missing/Invalid" S RETCODE=17
- . S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- Q
- ;
- TRIMTAIL(INSTR) ;
- N OUTSTR,CHR
- ;
- I $G(INSTR)="" Q "" ; quit if nothing there
- ;
- S INSTR=$RE(INSTR)
- S CHR=$E($TR(INSTR,CPS_REP))
- I CHR]"" Q $RE($P(INSTR,CHR,2,200))_CHR
- Q ""
- ;
- ; DECODE - Normalize data for display
- ; Input:
- ; INSTR - String to normalize
- ; Output
- ; Normalize data
- DECODE(INSTR) ;
- N TRCH
- S TRCH("\F\")="|",TRCH("\R\")="~",TRCH("\E\")="\"
- S TRCH("\T\")="&",TRCH("\S\")="^"
- Q $$DECODE^BPSJZPR(INSTR,.TRCH)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSJVAL2 5319 printed Jan 18, 2025@02:52:21 Page 2
- BPSJVAL2 ;BHAM ISC/LJF - Validate Pharmacy data ;3/5/08 11:14
- +1 ;;1.0;E CLAIMS MGMT ENGINE;**1,2,5,7**;JUN 2004;Build 46
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 NEW PHARMIX,RET,DIR,X
- +5 ;
- +6 SET PHARMIX=0
- SET X=""
- +7 FOR
- SET PHARMIX=$ORDER(^BPS(9002313.56,PHARMIX))
- if 'PHARMIX
- QUIT
- Begin DoDot:1
- +8 WRITE !!,"VERIFY PHARMACY REGISTRATIONS DATA.",!
- +9 DO REG^BPSJPREG(PHARMIX,2)
- +10 WRITE !
- +11 SET DIR(0)="EO"
- DO ^DIR
- End DoDot:1
- if X=U
- QUIT
- +12 ;
- +13 QUIT
- +14 ;
- +15 ; Array HL and variable VERBOSE newed/set by calling routine
- +16 ; RETCODE returned to calling routine
- VALIDATE(BPSJDDD) ;
- +1 NEW SEG,SEGIX,ZRP,RAY,RIX,PIX,PIXL,SEGDAT,ZNOTE,ZMAX,CPS,FS,REP
- +2 NEW VALDATA,TMP
- +3 SET ZMAX=17
- +4 ;
- +5 SET RETCODE=$GET(RETCODE)
- +6 SET ZRP=""
- SET RIX=0
- +7 ;
- +8 ; Set HL7 Delimiters - use standard defaults if none provided
- +9 SET FS=$GET(HL("FS"))
- IF FS=""
- SET FS="|"
- +10 SET CPS=$EXTRACT($GET(HL("ECH")))
- IF CPS=""
- SET CPS="^"
- +11 SET REP=$EXTRACT($GET(HL("ECH")),2)
- IF REP=""
- SET REP="~"
- +12 ;
- +13 FOR SEGIX=3:1
- SET SEG=$GET(^TMP("HLS",$JOB,SEGIX))
- SET PIX=0
- if SEG=""
- QUIT
- Begin DoDot:1
- +14 IF $EXTRACT(SEG,1,3)="ZRP"
- SET ZRP=$EXTRACT(SEG,4)
- SET $EXTRACT(SEG,1,4)=""
- End DoDot:1
- IF ZRP]""
- QUIT
- +15 IF ZRP=""
- QUIT
- +16 FOR
- SET RIX=$ORDER(^TMP("HLS",$JOB,SEGIX,RIX))
- if 'RIX
- QUIT
- IF RIX<(ZMAX+1)
- Begin DoDot:1
- +17 SET TMP=$PIECE($GET(^TMP("HLS",$JOB,SEGIX,RIX)),ZRP)
- +18 IF $GET(TMP)=""
- SET RETCODE(RIX)=""
- +19 ;capture pharmacy name
- IF RIX=3
- SET RETCODE(RIX)=TMP
- End DoDot:1
- +20 FOR
- SET RIX=$ORDER(RETCODE(RIX))
- if 'RIX
- QUIT
- Begin DoDot:1
- +21 DO @RIX
- +22 IF +$GET(VERBOSE)
- IF $LENGTH($GET(RETCODE(RIX)))
- WRITE !,RETCODE(RIX)
- End DoDot:1
- +23 ;
- +24 QUIT
- +25 ;
- +26 ; NS=Not Supported, R=Required, RE=Required or empty, C=Conditional
- +27 ; CE=Conditional or empty, O=Optional,
- +28 ;
- 1 ; Set ID - NS
- +1 QUIT
- 2 ; NCPDP Number - C
- +1 SET ZNOTE=" NCPDP NUMBER - VALID"
- +2 IF RETCODE(RIX)=""
- Begin DoDot:1
- +3 IF BPSJDDD=0
- Begin DoDot:2
- +4 IF '$DATA(RETCODE(17))
- QUIT
- +5 SET ZNOTE="** NCPDP NUMBER - NCPDP OR NPI - Missing/Invalid"
- SET RETCODE=2
- +6 SET RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- End DoDot:2
- End DoDot:1
- +7 QUIT
- 3 ; PHARMACY NAME - R
- +1 SET ZNOTE=" PHARMACY NAME"
- +2 IF RETCODE(RIX)=""
- Begin DoDot:1
- +3 SET ZNOTE="** PHARMACY NAME - Missing/Invalid"
- SET RETCODE=3
- End DoDot:1
- +4 IF RETCODE(RIX)]""
- SET RETCODE(RIX)=": "_$$DECODE(RETCODE(RIX))
- +5 SET RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- +6 QUIT
- 4 ; DEA Number - R
- +1 SET ZNOTE=" DEA NUMBER - Required - VALID"
- +2 IF RETCODE(RIX)=""
- Begin DoDot:1
- +3 SET ZNOTE="** DEA NUMBER - Missing/Invalid"
- SET RETCODE=4
- +4 SET RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- End DoDot:1
- +5 QUIT
- 5 ; Hour of Operation
- +1 ; not sending anymore
- SET ZNOTE=""
- +2 QUIT
- 6 ; Mailing Address - R
- +1 SET ZNOTE=$$TRIMTAIL(RETCODE(RIX))
- +2 ; Street address
- SET VALDATA=($LENGTH($PIECE(ZNOTE,CPS,1))<1)
- +3 ; City
- SET VALDATA=($LENGTH($PIECE(ZNOTE,CPS,3))<1)+VALDATA
- +4 ; State
- SET VALDATA=($LENGTH($PIECE(ZNOTE,CPS,4))<1)+VALDATA
- +5 ; Zip
- SET VALDATA=($LENGTH($PIECE(ZNOTE,CPS,5))<1)+VALDATA
- +6 SET ZNOTE=" MAILING ADDRESS - Required - VALID"
- +7 IF VALDATA
- Begin DoDot:1
- +8 SET ZNOTE="** MAILING ADDRESS - Missing/Invalid"
- SET RETCODE=6
- +9 SET RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- End DoDot:1
- +10 QUIT
- 7 ; Remittance Address - R
- +1 SET ZNOTE=$$TRIMTAIL(RETCODE(RIX))
- +2 ; Street Address
- SET VALDATA=($LENGTH($PIECE(ZNOTE,CPS,1))<1)
- +3 ; City
- SET VALDATA=($LENGTH($PIECE(ZNOTE,CPS,3))<1)+VALDATA
- +4 ; State
- SET VALDATA=($LENGTH($PIECE(ZNOTE,CPS,4))<1)+VALDATA
- +5 ; Zip
- SET VALDATA=($LENGTH($PIECE(ZNOTE,CPS,5))<1)+VALDATA
- +6 SET ZNOTE=" REMITTANCE ADDRESS - Required - VALID"
- +7 IF VALDATA
- Begin DoDot:1
- +8 SET ZNOTE="** REMITTANCE ADDRESS - Missing/Invalid"
- SET RETCODE=7
- +9 SET RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- End DoDot:1
- +10 QUIT
- 8 ; Contact Name
- +1 SET ZNOTE=$$TRIMTAIL(RETCODE(RIX))
- +2 ; Surname
- SET VALDATA=($LENGTH($PIECE(ZNOTE,CPS,1))<1)
- +3 SET ZNOTE=" CONTACT NAME - Required - VALID"
- +4 IF VALDATA
- Begin DoDot:1
- +5 SET ZNOTE="** CONTACT NAME - Missing/Invalid"
- SET RETCODE=8
- +6 SET RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- End DoDot:1
- +7 QUIT
- 9 ; Contact Title
- +1 SET ZNOTE=" CONTACT TITLE - VALID"
- +2 QUIT
- 10 ; Contact means
- +1 SET ZNOTE=" CONTACT MEANS - VALID"
- +2 ;S RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- +3 QUIT
- 11 ; Alternate Contact Name
- +1 SET ZNOTE=$$TRIMTAIL(RETCODE(RIX))
- +2 ; Surname
- SET VALDATA=($LENGTH($PIECE(ZNOTE,CPS,1))<1)
- +3 SET ZNOTE=" ALTERNATE CONTACT NAME - Required - VALID"
- +4 IF VALDATA
- Begin DoDot:1
- +5 SET ZNOTE="** ALTERNATE CONTACT NAME - Missing/Invalid"
- SET RETCODE=11
- +6 SET RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- End DoDot:1
- +7 QUIT
- 12 ; Alternate Contact Title
- +1 SET ZNOTE=" ALTERNATE CONTACT TITLE - VALID"
- +2 QUIT
- 13 ; Alternate Contact means
- +1 SET ZNOTE=" ALTERNATE CONTACT MEANS - VALID"
- +2 QUIT
- 14 ; Lead Pharmacist Name - R
- +1 SET ZNOTE=$$TRIMTAIL(RETCODE(RIX))
- +2 ; Surname
- SET VALDATA=($LENGTH($PIECE(ZNOTE,CPS,1))<1)
- +3 SET ZNOTE=" LEAD PHARMACIST NAME - Required - VALID"
- +4 IF VALDATA
- Begin DoDot:1
- +5 SET ZNOTE="** LEAD PHARMACIST NAME - Missing/Invalid"
- SET RETCODE=14
- +6 SET RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- End DoDot:1
- +7 QUIT
- 15 ; Lead Pharmacist Title
- +1 SET ZNOTE=" LEAD PHARMACIST TITLE - VALID"
- +2 QUIT
- 16 ; Lead Pharmacist License Number
- +1 SET ZNOTE=" LEAD PHARMACIST LICENSE NUMBER - VALID"
- +2 QUIT
- 17 ; NPI Number - C (R - AFTER DDD)
- +1 SET ZNOTE=" NPI NUMBER - Required - VALID "
- +2 IF RETCODE(RIX)=""
- Begin DoDot:1
- +3 IF BPSJDDD=0
- Begin DoDot:2
- +4 IF '$DATA(RETCODE(2))
- SET ZNOTE=" NPI NUMBER - Warning NPI NUMBER Missing "
- QUIT
- +5 SET ZNOTE="** NPI NUMBER - NPI OR NCPDP - Missing/Invalid"
- SET RETCODE=17
- End DoDot:2
- +6 IF BPSJDDD>0
- Begin DoDot:2
- +7 SET ZNOTE="** NPI NUMBER - Missing/Invalid"
- SET RETCODE=17
- End DoDot:2
- +8 SET RETCODE(RIX)=ZNOTE_RETCODE(RIX)
- End DoDot:1
- +9 QUIT
- +10 ;
- TRIMTAIL(INSTR) ;
- +1 NEW OUTSTR,CHR
- +2 ;
- +3 ; quit if nothing there
- IF $GET(INSTR)=""
- QUIT ""
- +4 ;
- +5 SET INSTR=$REVERSE(INSTR)
- +6 SET CHR=$EXTRACT($TRANSLATE(INSTR,CPS_REP))
- +7 IF CHR]""
- QUIT $REVERSE($PIECE(INSTR,CHR,2,200))_CHR
- +8 QUIT ""
- +9 ;
- +10 ; DECODE - Normalize data for display
- +11 ; Input:
- +12 ; INSTR - String to normalize
- +13 ; Output
- +14 ; Normalize data
- DECODE(INSTR) ;
- +1 NEW TRCH
- +2 SET TRCH("\F\")="|"
- SET TRCH("\R\")="~"
- SET TRCH("\E\")="\"
- +3 SET TRCH("\T\")="&"
- SET TRCH("\S\")="^"
- +4 QUIT $$DECODE^BPSJZPR(INSTR,.TRCH)