Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCNOR3

IBCNOR3.m

Go to the documentation of this file. 
  1. IBCNOR3 ;AITC/DTG - IBCN EDI PAYER ID REPT ;10/18/23
  1.  ;;2.0;INTEGRATED BILLING;**778**;21-MAR-94;Build 28
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ; Reference to EN^XUTMDEVQ in ICR #1519
  1.  ;
  1.  Q
  1.  ;
  1. EN ; entry point
  1.  ;
  1.  N DIR,IBAR,IBCK,IBCNT,IBI,IBID,IBOK,IBOUT,IBSTOP,IBXSAV,POP,X,Y
  1.  K ^TMP("IBCNOR3",$J) S ^TMP("IBCNOR3",$J,0)=""
  1.  W:$G(IOF)'="" @IOF W:$G(IOF)="" !
  1.  W !,"This report allows the user to identify Insurance Companies with a specific",!,"EDI Payer ID."
  1.  ; get edi number
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1. ENRK ; come here if continue from ^ response
  1.  K ^TMP("IBCNOR3",$J) S ^TMP("IBCNOR3",$J,0)=""
  1. ENR ; ask question return point. 
  1.  W !
  1.  S IBCNT=0
  1.  S DIR(0)="F^1:30"
  1.  S DIR("A")="Please Enter an EDI Payer ID"
  1.  S DIR("?",1)="Enter an EDI Payer ID (Includes: PROFESSIONAL, INSTITUTIONAL, and/or"
  1.  S DIR("?")="DENTAL Number) from 1 to 30 characters or '^' to quit."
  1.  S IBOK=0
  1. ENAQ ;
  1.  D ^DIR
  1.  I $E(Y,1)=" " S IBOK=0 D  I 'IBOK S Y="" W !,"This is a required response. Enter '^' to exit" G ENAQ
  1.  . F IBI=1:1:$L(Y) I $E(Y,IBI)'=" " S IBOK=1 Q
  1.  I $E(Y)=U!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT) S Y="^"
  1.  D ISET
  1.  I $E(Y)=U G EXIT
  1.  ;
  1.  S IBSTOP=0 D OUT I IBSTOP G:$$STOP EXIT G ENRK
  1.  ;
  1.  D DEVICE
  1.  G EXIT
  1.  ;
  1. ISET ; if item save and set flag
  1.  ;
  1.  N IBA,IBC,IBD,IBE
  1.  I Y=""!($E(Y)=U) Q  ; leave IBOK 0 in order to stop
  1.  S IBOK=1,IBFND=0
  1.  S IBA=$G(^TMP("IBCNOR3",$J,1,Y))
  1.  I IBA W *7,"    EDI Payer ID already selected" Q
  1.  S ^TMP("IBCNOR3",$J,1,Y)=1,IBCNT=IBCNT+1,^TMP("IBCNOR3",$J,0)=IBCNT
  1.  Q
  1.  ;
  1.  ;
  1. OUT ; Prompt to allow users to select output format
  1.  ; Returns: E - Output to excel
  1.  ;          R - Output to report
  1.  ;     IBSTOP=1 - No Selection made
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  W !
  1.  S DIR(0)="SA^E:Excel;R:Report"
  1.  S DIR("A")="(E)xcel Format or (R)eport Format: "
  1.  S DIR("B")="Report"
  1.  S DIR("?",1)="Select 'E' to create CSV output for import into Excel."
  1.  S DIR("?")="Select 'R' to create a standard report."
  1.  D ^DIR K DIR
  1.  I $D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT) S IBSTOP=1 G OUTQ
  1.  S IBOUT=Y
  1.  Q
  1. OUTQ ;
  1.  ;
  1.  Q
  1.  ;
  1. EXIT ; quit point
  1.  ;
  1.  K ^TMP("IBCNOR3",$J)
  1.  Q
  1.  ;
  1. DEVICE ;
  1.  N DIR,IBB,IBC,IBJOB,POP,ZTDESC,ZTRTN,ZTSAVE
  1.  I IBOUT="R" W !!,"You will need a 132 column printer for this report.",!
  1.  I IBOUT="E" D
  1.  . W !!,"For CSV output, turn logging or capture on now.",!
  1.  . W "To avoid undesired wrapping of the data, please"
  1.  . W !," enter '0;256;99999'.",!
  1.  K IBXSAV M IBXSAV=^TMP("IBCNOR3",$J)
  1.  S ZTRTN="COMPILE^IBCNOR3"
  1.  S ZTDESC="EP - EDI Payer ID Report"
  1.  F IBB="IBOUT","IBC","IBXSAV(" S ZTSAVE(IBB)=""
  1.  D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"Q")   ; ICR # 1519
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. COMPILE ; build output of payers
  1.  ;
  1.  N %,IB36,IBADDR,IBARY,IBCHK,IBCTY,IBCRT,IBDASHES,IBEORMSG,IBFILTER,IBHDR
  1.  N IBHDRDATE,IBHDRNAME,IBINDX,IBITM,IBL,IBLOOK,IBLNC,IBMAXCNT,IBNM,IBNONEMSG
  1.  N IBPGC,IBSPACES,IBST,IBSTAB,IBSTOP,IBSTREET,IBUN,IBW,IBXTFEED,IBZIP
  1.  ;
  1.  S IBOUT=$G(IBOUT),IBC=$G(IBC)
  1.  S IBCHK=0
  1.  S IBMAXCNT=IOSL-3,IBXTFEED=21,IBCRT=1,IBLNC=0
  1.  I IOST'["C-" S IBMAXCNT=IOSL-6,IBXTFEED=50,IBCRT=0
  1.  S IBEORMSG="*** End of Report ***"
  1.  S IBNONEMSG="* * * N o   D a t a   F o u n d * * *"
  1.  S IBHDRNAME="EDI PAYER ID REPORT"
  1.  D NOW^%DTC
  1.  S IBHDRDATE=$$DAT2^IBOUTL($E(%,1,12))
  1.  S $P(IBDASHES,"-",132)=""
  1.  S $P(IBSPACES," ",80)=""
  1.  S IBHDR="HDR"_$S(IBOUT="E":"E",1:"R")
  1.  K ^TMP($J,"IBCNOR3")
  1.  K ^TMP($J,"IBCNOR3-1")
  1.  K IBFND
  1.  M ^TMP($J,"IBCNOR3")=IBXSAV
  1.  ;
  1.  ;compile
  1.  ;
  1.  I IBCRT W !,"Checking Insurance Companies for the EDI Payer number(s)",!
  1.  S IBFILTER="SELECTED: "
  1.  S IBLOOK="",IBCHK=0
  1.  ; get ID add to display and make uppercase
  1.  F  S IBLOOK=$O(^TMP($J,"IBCNOR3",1,IBLOOK)) Q:IBLOOK=""  D  S IBCHK=IBCHK+1
  1.  . S IBFILTER=IBFILTER_($S('+IBCHK:"",1:", "))_IBLOOK,IBUN=$$UP^XLFSTR(IBLOOK),^TMP($J,"IBCNOR3",2,IBUN)=1
  1.  D WALK
  1.  ;
  1. PRINT ; out put the compile in insurance co name order
  1.  ;
  1.  N IBFIL
  1.  S IBFIL="," S:$G(IBOUT)="R" IBFIL=IBFIL_" "
  1.  K IBW,IBARY
  1.  S IBPGC=0
  1.  I '+$G(^TMP($J,"IBCNOR3-1",2)) D NOD G EXITC
  1.  D:IBOUT="E" HDRE D:IBOUT="R" HDRR
  1.  S IBSTOP=0,IBNM="" F  S IBNM=$O(^TMP($J,"IBCNOR3-1",1,IBNM)) Q:IBNM=""  D  Q:IBSTOP
  1.  . S IBSTREET="" F  S IBSTREET=$O(^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET)) Q:IBSTREET=""  D  Q:IBSTOP
  1.  .. S IBCTY="" F  S IBCTY=$O(^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY)) Q:IBCTY=""  D  Q:IBSTOP
  1.  ... S IBSTAB="" F  S IBSTAB=$O(^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB)) Q:IBSTAB=""  D  Q:IBSTOP
  1.  .... S IBZIP="" F  S IBZIP=$O(^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB,IBZIP)) Q:IBZIP=""  D  Q:IBSTOP
  1.  ..... S IB36="" F  S IB36=$O(^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB,IBZIP,IB36)) Q:'IB36  D  Q:IBSTOP
  1.  ...... S IBW=$G(^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB,IBZIP,IB36))
  1.  ...... S IBADDR=$S(IBSTREET'=" ":IBSTREET,1:"")_IBFIL_$S(IBCTY'=" ":IBCTY,1:"")_IBFIL
  1.  ...... S IBADDR=IBADDR_$S(IBSTAB'=" ":IBSTAB,1:"")_IBFIL_$S(IBZIP'=" ":IBZIP,1:"")
  1.  ...... I IBOUT="E" D  Q
  1.  ....... W !,IBNM,U,IBADDR,U,IBW
  1.  ...... I IBOUT="R" D
  1.  ....... W !,IBNM,?32,$P(IBW,U,1),?64,$P(IBW,U,2),?96,$P(IBW,U,3),?128,$P(IBW,U,4)
  1.  ....... W !,"   ",IBADDR
  1.  ....... S IBLNC=IBLNC+2 I (IBPGC>0),(IBLNC+2>IBMAXCNT) D
  1.  ........ D QLINE Q:IBSTOP
  1.  ........ D:IBOUT="E" HDRE D:IBOUT="R" HDRR
  1.  I IBSTOP G EXITC
  1.  W !,IBEORMSG
  1.  D QLINE
  1.  G EXITC
  1.  ;
  1. NOD ; no info to print
  1.  ;
  1.  D:IBOUT="E" HDRE D:IBOUT="R" HDRR
  1.  W !,IBNONEMSG,!,IBEORMSG
  1.  D QLINE
  1.  Q
  1.  ;
  1. QLINE ; cr to continue
  1.  ;
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LIN
  1.  W !
  1.  I 'IBCRT Q
  1.  S DIR(0)="E" D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT) S IBSTOP=1
  1.  Q
  1.  ;
  1. WALK ; walk the indexes
  1.  ;
  1.  N IB36,IBARY,IBCHK,IBCK,IBCKA,IBCTY,IBI,IBNM,IBS,IBST,IBSTAB,IIBSTREET,IBW,IBZIP
  1.  S IB36=0,IBCHK=0 F  S IB36=$O(^DIC(36,IB36)) Q:'IB36  D
  1.  . S IBCHK=IBCHK+1 I IBCRT&(IBCHK#500=0) W "."
  1.  . I '$D(^DIC(36,IB36,0)) Q  ; zero record not found
  1.  . I $D(^TMP($J,"IBCNOR3-1",0,IB36)) Q  ; already picked up. the same edi number can be used multiple times
  1.  . K IBARY D GETS^DIQ(36,IB36_",",".01;.05;.111;.114;.115;.116;3.02;3.04;3.15","IE","IBARY")
  1.  . K IBW M IBW=IBARY(36,IB36_",")
  1.  . ; check if in array
  1.  . S IBCKA=0
  1.  . F IBI=$G(IBW(3.02,"I")),$G(IBW(3.04,"I")),$G(IBW(3.15,"I")) D  Q:IBCKA
  1.  .. I IBI=""!(IBI=" ") Q
  1.  .. S IBCK=$$UP^XLFSTR(IBI)
  1.  .. I '$D(^TMP($J,"IBCNOR3",2,IBCK)) Q
  1.  .. S ^TMP($J,"IBCNOR3-1",0,IB36)=1
  1.  .. S IBNM=$G(IBW(.01,"E")),IBSTREET=$G(IBW(.111,"E")),IBCTY=$G(IBW(.114,"E"))
  1.  .. S IBST=$G(IBW(.115,"I")),IBZIP=$G(IBW(.116,"E"))
  1.  .. S IBSTAB="" I IBST S IBSTAB=$$GET1^DIQ(5,IBST_",","1","I")
  1.  .. S:IBNM="" IBNM=" " S:IBSTREET="" IBSTREET=" "
  1.  .. S:IBCTY="" IBCTY=" " S:IBSTAB="" IBSTAB=" " S:IBZIP="" IBZIP=" "
  1.  .. S IBS=$G(IBW(3.02,"I"))_U_$G(IBW(3.04,"I"))_U_$G(IBW(3.15,"I"))_U_$S('$G(IBW(.05,"I")):"A",1:"I")
  1.  .. S ^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB,IBZIP,IB36)=IBS
  1.  .. S ^TMP($J,"IBCNOR3-1",2)=$G(^TMP($J,"IBCNOR3-1",2))+1
  1.  .. S IBCKA=1
  1.  Q
  1.  ;
  1. HDRE ; excel header
  1.  ;
  1.  W !,IBHDRNAME,U,IBHDRDATE
  1.  W !,IBFILTER
  1.  W !,"INSURANCE COMPANY"_U_"ADDRESS"_U_"PROFESSIONAL ID"_U_"INSTITUTIONAL ID"_U_"DENTAL ID"_U_"A/I"
  1.  ;
  1.  Q
  1.  ;
  1. HDRR ; report header
  1.  ;
  1.  N IBA,IBF,IBG
  1.  S IBPGC=$G(IBPGC)+1 I IBCRT W:$G(IOF)'="" @IOF W:$G(IOF)="" !
  1.  I 'IBCRT W !
  1.  S IBA=$E(IBSPACES,1,(6-$L(IBPGC)))_IBPGC,IBLNC=6
  1.  W IBHDRNAME,?90,IBHDRDATE,?119,"Page: ",IBA,!
  1.  S IBLNC=5 W IBFILTER,!!
  1.  W "INSURANCE COMPANY",?32,"PROFESSIONAL ID",?64,"INSTITUTIONAL ID",?96,"DENTAL ID",?128,"A/I"
  1.  W !,$E(IBDASHES,1,132)
  1.  Q
  1.  ;
  1. EXITC ; compile section exit
  1.  ;
  1.  K ^TMP($J,"IBCNOR3-1")
  1.  K ^TMP($J,"IBCNOR3")
  1.  Q
  1.  ;
  1. STOP() ; Determine if user wants to exit out of the whole option
  1.  ; Initialize Variables
  1.  N DIR,DIRUT,X,Y
  1.  W !
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Do you want to exit out of this option entirely"
  1.  S DIR("B")="YES"
  1.  S DIR("?",1)=" Enter YES to immediately exit out of this option."
  1.  S DIR("?")=" Enter NO to return to the previous question."
  1.  D ^DIR K DIR
  1.  I $D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT) S (IBSTOP,Y)=1 G STOPX
  1.  I 'Y S IBSTOP=0
  1. STOPX ; STOP Exit Point
  1.  Q Y
  1.  ;