IBARXMI.m

IBARXMI ;OAK/ELZ-HL7 RECEIVER FOR PFSS WORKING ROUTINE ;6-APR-2005

 ;;2.0;INTEGRATED BILLING;**308**;21-MAR-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

QUERYVA ; called by HL7 receiver to send queries out to all sites of record

 ; for the given patient to look for updated copay cap information.

 ; TYPE = ST

 ;

 N IBADT,IBRX,X,IBX,IBQ

 ;

 ;check out data received from message (need to get rx/fill number that caused this)

 S IBQ=0 F IBX=.091,.092,.03 I $G(IB35471(IBX))="" S IBQ=1 Q

 I IBQ S HLERR="354.71 field "_IBX_" missing" Q

 S IBRX=$O(^PSRX("B",IB35471(.091),0)) I 'IBRX S HLERR="Rx number not found" Q

 I '$D(^PSRX(+IBRX,1,IB35471(.092),0)),IB35471(.092) S HLERR="Refill invalid or not found" Q

 ;

 ; set DUZ to pharmacy person who caused this to occur DBIA4732 and SACC exemption

 D

 . I $G(DUZ)<1,$L($T(RPH^PSOPFSU0)) N DUZ S DUZ=$P($$RPH^PSOPFSU0(IB35471(.091),IB35471(.092)),"^",2),DUZ(2)=+$$SITE^VASITE

 . ;

 . ; call to do query

 . S IBADT=IB35471(.03)

 . D BBE^IBARXPFS

 ;

 ; call vdef to say done

 S X=$$QUEUE^VDEFQM("DFT^P03","SUBTYPE=CPFI^IEN="_DFN,,"PFSS OUTBOUND")

 ;

 Q

 ;

BILLVA ; called by HL7 receiver to initiate back billing at a remote VA site.

 ; TYPE = BL

 ;

 N IBX,IBRX,IBQ

 ;

 ;check out data received from message

 S IBQ=0 F IBX=.01,.11,.091,.092 I $G(IB35471(IBX))="" S IBQ=1 Q

 I IBQ S HLERR="354.71 field "_IBX_" missing" Q

 I IB35471(.11)<.01 S HLERR="Invalid amount to back bill" Q

 S IBX=$O(^IBAM(354.71,"B",IB35471(.01),0)) I 'IBX S HLERR="Invalid 354.71 transaction number" Q

 S IBRX=$O(^PSRX("B",IB35471(.091),0)) I 'IBRX S HLERR="Rx number not found" Q

 I '$D(^PSRX(+IBRX,1,IB35471(.092),0)),IB35471(.092) S HLERR="Refill invalid or not found" Q

 ;

 ;need to set DUZ to pharmacy staff person who caused this to occur DBIA4732 and SACC exemption

 D

 . I $G(DUZ)<1,$L($T(RPH^PSOPFSU0)) N DUZ S DUZ=$P($$RPH^PSOPFSU0(IBRX,IB35471(.092)),"^",2),DUZ(2)=+$$SITE^VASITE

 . ;

 . ;call remote site to do back billing for specified $ amount

 . I +IB35471(.01)'=$P($$SITE^VASITE,"^",3) D SEND^IBARXMB(IB35471(.01),IB35471(.11)) Q

 . I +IB35471(.01)=$P($$SITE^VASITE,"^",3),'$P(^IBAM(354.71,IBX,0),"^",20) D BILL^IBARXMB(IB35471(.01),IB35471(.11)) Q

 . S HLERR="Transaction from local VistA or remote VA site"

 ;

 Q

 ;

35471 ; files data into 354.71 (TYPE = IN)

 ; validate data

 N IBX,IBQ,IBRX,IBARXDAT,IBATYP,IBAM,IBDESC

 I '$L($T(RPH^PSOPFSU0)) S HLERR="Pharmacy API not installed" Q

 S IBQ=0 F IBX=.01,.03,.05,.07,.08,.091,.1,.11,.12 I $G(IB35471(IBX))="" S IBQ=1 Q

 I IBQ S HLERR="354.71 field "_IBX_" missing" Q

 ;

 I $P($$SITE^VASITE,"^",3)'=+IB35471(.01)!(IB35471(.01)'?3N1"-"1N.N) S HLERR="354.71 field .01 invalid" Q

 I $P($$SITE^VASITE,"^",3)'=+IB35471(.1)!(IB35471(.1)'?3N1"-"1N.N) S HLERR="354.71 field .1 invalid" Q

 I IB35471(.1)'=IB35471(.01),$O(^IBAM(354.71,"B",IB35471(.1),0)) S HLERR="354.71 field .1 is not a valid parent" Q

 F IBX=.08,.11,.12 S IB35471(IBX)=+IB35471(IBX)

 I 'IB35471(.08) S HLERR="Total Charge in-valid" Q

 S IBRX=$O(^PSRX("B",IB35471(.091),0)) I 'IBRX S HLERR="Invalid prescription number" Q

 I IB35471(.092),'$D(^PSRX(IBX,1,IB35471(.092),0)) S HLERR="Invalid fill/refill number" Q

 F IBX=.01,.03,.05,.07,.08,.11,.12 D CHK^DIE(354.71,IBX,,IB35471(IBX),.IBQ) I IBQ="^" S HLERR="File 354.71, field "_IBX_" does not pass DD check" Q

 ;

 ;look up some needed rx data

 S IBARXDAT=$$RPH^PSOPFSU0(IBRX,+IB35471(.092))

 I $P(IBARXDAT,"^",3)="" S HLERR="Bad prescription data" Q

 ;

 ;get brief description

 S IBX="52:"_IBRX_$S(IB35471(.092):";1:"_IB35471(.092),1:"")_"^"_IB35471(.07)

 D ELIG^VADPT,INP^VADPT,DOM^IBARX

 S IBATYP=$O(^IBE(350.1,"ANEW",$P(IBARXDAT,"^",3),1,0))

 D BDESC^IBARX1

 ;

 ;need to set DUZ to pharmacy staff person who caused this to occur

 D

 . I $G(DUZ)<1 N DUZ S DUZ=$S(IB35471(.05)="NEW":$P(IBARXDAT,"^"),1:$P(IBARXDAT,"^",2)),DUZ(2)=+$$SITE^VASITE

 . N DIE,DR,DA

 . ;

 . ;file in 354.71

 . S IBAM=$$ADD^IBARXMN(DFN,IB35471(.01)_"^"_DFN_"^"_IB35471(.03)_"^^"_IB35471(.05)_"^"_$P(IBX,"^")_"^"_IB35471(.07)_"^"_IB35471(.08)_"^"_IBDESC_"^"_IB35471(.1)_"^"_IB35471(.11)_"^"_IB35471(.12)_"^"_$$LKUP^XUAF4(+IB35471(.01)),,1)

 . S DIE="^IBAM(354.71,",DA=IBAM,DR=".2////1" D ^DIE

 . ;

 . ;call to send data to remote sites

 . D FOUND^IBARXMA(.IBX,IBAM)

 ;

 D KVA^VADPT

 ;

 Q

 ;

351 ; files data in 351 (MT type)

 ;

 N IBQ,IBX,DIC,DIE,DR,X,Y,DA,DO

 ;

 ;validate data

 S IBQ=0 F IBX=.03,.04,.05,.06,.07,.08,.09,.1 I $G(IB351(IBX))="" S IBQ=1 Q

 I IBQ S HLERR="351 field "_IBX_" missing" Q

 I '$G(IB35471(.01)) S HLERR="Clock file number missing or invalid" Q

 S IB351(.01)=IB35471(.01)

 F IBX=.01,.03,.04,.05,.06,.07,.08,.09,.1 D CHK^DIE(351,IBX,,IB351(IBX),.IBQ) I IBQ="^" S HLERR="File 351, field "_IBX_" does not pass DD check" Q

 ;

 ; see if clock already exists or add

 S IBX=$O(^IBE(351,"B",IB35471(.01),0))

 I 'IBX S DIC="^IBE(351,",X=IB351(.01),DIC(0)="",DIC("DR")=".02////^S X=DFN;11////"_$S($D(DUZ):DUZ,1:.5)_";12///NOW;13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW" K DO D FILE^DICN S IBX=+Y

 I DFN'=$P($G(^IBE(351,IBX,0)),"^",2) S HLERR="Patient does not match clock file entry" Q

 ;

 ; file data received

 S DIE="^IBE(351,",DA=IBX,DR=".04///^S X=IB351(.04);13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW" F X=.03,.05,.06,.07,.08,.09,.1 S DR=DR_";"_X_"////"_+IB351(X)

 D ^DIE

 Q

 ;

35181 ; files data in 351.81 (LB type)

 ;

 N IBQ,IBX,DIC,DIE,DR,X,Y,IBY,DA,DO,DIK,IBLTCX

 ;

 ;validate data

 S IBQ=0 F IBX=.03,.04,.05 I $G(IB35181(IBX))="" S IBQ=1 Q

 I IBQ S HLERR="351.81 field "_IBX_" missing" Q

 I '$G(IB35471(.01)) S HLERR="LTC Clock file number missing or invalid" Q

 S IB35181(.01)=IB35471(.01)

 F IBX=.01,.03,.04,.05 D CHK^DIE(351.81,IBX,,IB35181(IBX),.IBQ) I IBQ="^" S HLERR="File 351.81, field "_IBX_" does not pass DD check" Q

 S IBX=0 F  S IBX=$O(IBMTDT21(IBX)) Q:'IBX  D CHK^DIE(351.811,.02,,IBMTDT21(IBX),.IBQ)  I IBQ="^" S HLERR="LTC Exempt date "_IBMTDT21(IBX)_" does not pass DD check" Q

 ;

 ; see if clock already exists or add

 S IBX=$O(^IBA(351.81,"B",IB35181(.01),0))

 I 'IBX S DIC="^IBA(351.81,",X=IB35181(.01),DIC(0)="",DIC("DR")=".02////^S X=DFN;4.01////"_$S($D(DUZ):DUZ,1:.5)_";4.02///NOW;4.03////"_$S($D(DUZ):DUZ,1:.5)_";4.04///NOW" K DO D FILE^DICN S IBX=+Y

 I DFN'=$P($G(^IBA(351.81,IBX,0)),"^",2) S HLERR="Patient does not match LTC clock file entry" Q

 ;

 ; file top level file data received

 S DIE="^IBA(351.81,",DA=IBX,DR="4.03////"_$S($D(DUZ):DUZ,1:.5)_";4.04///NOW" F X=.03,.04,.05 S DR=DR_";"_X_"////"_+IB35181(X)

 D ^DIE

 ;

 ; clean out 21 days and re-file based on data received

 S DIK="^IBA(351.81,"_IBX_",1,",DA(1)=IBX,IBY=0 F  S IBY=$O(^IBA(351.81,IBX,1,IBY)) Q:'IBY  S DA=IBY D ^DIK

 S DIC=DIK,DIC(0)="",IBY=0 F  S IBY=$O(IBMTDT21(IBY)) Q:'IBY  S X=IBY,DIC("DR")=".02////^S X=IBMTDT21(IBY)" K DO D FILE^DICN

 S IBLTCX=IBX D REINDEX^IBAECC

 ;

 Q

 ;

350 ; files data in 350 (ML type)

 N IBQ,IBX,DIC,DIE,DR,X,Y,IBY,DA,DO,IBDESC

 ;

 ; do i have data

 S IBQ=0 F IBX="TYP","IO","BS","EDT",.06,.07,.17,.14,.15,.05,"IDX" I $G(IB350(IBX))="" S IBQ=1 Q

 I IBQ S HLERR="350 field "_IBX_" missing" Q

 I $G(IB35471(.01))="" S HLERR="350 field .01 mssing" Q

 ;

 ;determine action type

 S IB350(.03)=$$ATYPE(IB350("TYP"),IB350("IO"),IB350("BS")) I IB350(.03)=-1 S HLERR="Unable to determine Action Type" Q

 S IB350(.03)=$O(^IBE(350.1,"B",IB350(.03),0)) I 'IB350(.03) S HLERR="Action Type not found in 350.1" Q

 ;

 ;determine brief description if any

 I $D(^IBE(350.1,IB350(.03),20)) X ^(20)

 ;

 ;determine institution (defualt to here if not known)

 S IB350(.13)=$S($D(IBINST):$$LKUP^XUAF4(IBINST),1:+$$SITE^VASITE)

 ;

 ;determine clinic stop if needed

 I IB350("IO")="O" S IB350(.2)=$$GET3525^IBEMTSCU($E($G(IB350(.2)),1,3),$E($G(IB350(.2)),4,6),IB350(.17)) I 'IB350(.2) S HLERR="Unable to find valid clinic stop code in 352.5" Q

 ;

 ;check out data

 S IB350(.01)=IB35471(.01)

 F IBX=.01,.06,.07,.17,.14,.15,.05 D CHK^DIE(350,IBX,,IB350(IBX),.IBQ) I IBQ="^" S HLERR="File 350, field "_IBX_" does not pass DD check" Q

 I $L($G(HLERR)) Q

 S IB350(.22)=$O(^IBBAA(375,"C",IB350("IDX"),0)) I 'IB350(.22) S HLERR="PFSS Account Number not found" Q

 ;

 ;see if already exists or add

 S IBX=$O(^IB("B",IB350(.01),0))

 I 'IBX S DIC="^IB(",X=IB350(.01),DIC(0)="",DIC("DR")=".02////^S X=DFN;11////"_$S($D(DUZ):DUZ,1:.5)_";12///NOW;13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW" K DO D FILE^DICN S IBX=+Y

 I DFN'=$P($G(^IB(IBX,0)),"^",2) S HLERR="Patient does not match IB file entry" Q

 ;

 ;file data

 S DIE="^IB(",DA=IBX,DR=".05///^S X=IB350(.05);13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW"_$S(IB350("IO")="O":";.2////^S X=IB350(.2)",1:"")_$S($D(IBDESC):";.08////^S X=IBDESC",1:"")

 F IBY=.03,.06,.07,.13,.17,.14,.15,.22 S:'$L($P(^IB(IBX,0),"^",IBY*100)) DR=DR_";"_IBY_"////"_(+IB350(IBY))

 D ^DIE

 ;

 Q

 ;

ERR ; trans type not found, set error

 S HLERR="Transaction Type field not valid (.6)."

 Q

 ;

ATYPE(IBTYP,IBIO,IBBS) ; used to determine action type

 I IBTYP="MT",IBIO="O" Q "DG OPT COPAY NEW"

 I IBTYP="MT",IBIO="I" Q "DG INPT COPAY ("_IBBS_") NEW"

 I IBTYP="GMT",IBIO="I" Q "DG INPT COPAY ("_IBBS_") NEW"

 I IBTYP="LTC",IBIO="O" Q "DG LTC OPT "_IBBS_" NEW"

 I IBTYP="LTC",IBIO="I" Q "DG LTC INPT "_IBBS_" NEW"

 I IBTYP="FEE",IBIO="O" Q "DG FEE SERVICE (OPT) NEW"

 I IBTYP="FEE",IBIO="I" Q "DG FEE SERVICE (INPT) NEW"

 I IBTYP="LTC FEE",IBIO="O" Q "DG LTC FEE OPT "_IBBS_" NEW"

 I IBTYP="LTC FEE",IBIO="I" Q "DG LTC FEE INPT "_IBBS_" NEW"

 I IBTYP="MT PERDIEM" Q "DG INPT PER DIEM NEW"

 I IBTYP="MT",IBBS="OBS" Q "DG OBSERVATION COPAY NEW"

 I IBTYP="CHAMPUS",IBIO="O" Q "DG TRICARE OPT COPAY NEW"

 I IBTYP="CHAMPUS",IBIO="I" Q "DG TRICARE INPT COPAY NEW"

 Q -1

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBARXMI   9786     printed  Feb 18, 2025@23:33:58                                                                                                                                                                                                     Page 2

IBARXMI   ;OAK/ELZ-HL7 RECEIVER FOR PFSS WORKING ROUTINE ;6-APR-2005

 +1       ;;2.0;INTEGRATED BILLING;**308**;21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

QUERYVA   ; called by HL7 receiver to send queries out to all sites of record

 +1       ; for the given patient to look for updated copay cap information.

 +2       ; TYPE = ST

 +3       ;

 +4        NEW IBADT,IBRX,X,IBX,IBQ

 +5       ;

 +6       ;check out data received from message (need to get rx/fill number that caused this)

 +7        SET IBQ=0

           FOR IBX=.091,.092,.03

               IF $GET(IB35471(IBX))=""

                   SET IBQ=1

                   QUIT 

 +8        IF IBQ

               SET HLERR="354.71 field "_IBX_" missing"

               QUIT 

 +9        SET IBRX=$ORDER(^PSRX("B",IB35471(.091),0))

           IF 'IBRX

               SET HLERR="Rx number not found"

               QUIT 

 +10       IF '$DATA(^PSRX(+IBRX,1,IB35471(.092),0))

               IF IB35471(.092)

                   SET HLERR="Refill invalid or not found"

                   QUIT 

 +11      ;

 +12      ; set DUZ to pharmacy person who caused this to occur DBIA4732 and SACC exemption

 +13       Begin DoDot:1

 +14           IF $GET(DUZ)<1

                   IF $LENGTH($TEXT(RPH^PSOPFSU0))

                       NEW DUZ

                       SET DUZ=$PIECE($$RPH^PSOPFSU0(IB35471(.091),IB35471(.092)),"^",2)

                       SET DUZ(2)=+$$SITE^VASITE

 +15      ;

 +16      ; call to do query

 +17           SET IBADT=IB35471(.03)

 +18           DO BBE^IBARXPFS

           End DoDot:1

 +19      ;

 +20      ; call vdef to say done

 +21       SET X=$$QUEUE^VDEFQM("DFT^P03","SUBTYPE=CPFI^IEN="_DFN,,"PFSS OUTBOUND")

 +22      ;

 +23       QUIT 

 +24      ;

BILLVA    ; called by HL7 receiver to initiate back billing at a remote VA site.

 +1       ; TYPE = BL

 +2       ;

 +3        NEW IBX,IBRX,IBQ

 +4       ;

 +5       ;check out data received from message

 +6        SET IBQ=0

           FOR IBX=.01,.11,.091,.092

               IF $GET(IB35471(IBX))=""

                   SET IBQ=1

                   QUIT 

 +7        IF IBQ

               SET HLERR="354.71 field "_IBX_" missing"

               QUIT 

 +8        IF IB35471(.11)<.01

               SET HLERR="Invalid amount to back bill"

               QUIT 

 +9        SET IBX=$ORDER(^IBAM(354.71,"B",IB35471(.01),0))

           IF 'IBX

               SET HLERR="Invalid 354.71 transaction number"

               QUIT 

 +10       SET IBRX=$ORDER(^PSRX("B",IB35471(.091),0))

           IF 'IBRX

               SET HLERR="Rx number not found"

               QUIT 

 +11       IF '$DATA(^PSRX(+IBRX,1,IB35471(.092),0))

               IF IB35471(.092)

                   SET HLERR="Refill invalid or not found"

                   QUIT 

 +12      ;

 +13      ;need to set DUZ to pharmacy staff person who caused this to occur DBIA4732 and SACC exemption

 +14       Begin DoDot:1

 +15           IF $GET(DUZ)<1

                   IF $LENGTH($TEXT(RPH^PSOPFSU0))

                       NEW DUZ

                       SET DUZ=$PIECE($$RPH^PSOPFSU0(IBRX,IB35471(.092)),"^",2)

                       SET DUZ(2)=+$$SITE^VASITE

 +16      ;

 +17      ;call remote site to do back billing for specified $ amount

 +18           IF +IB35471(.01)'=$PIECE($$SITE^VASITE,"^",3)

                   DO SEND^IBARXMB(IB35471(.01),IB35471(.11))

                   QUIT 

 +19           IF +IB35471(.01)=$PIECE($$SITE^VASITE,"^",3)

                   IF '$PIECE(^IBAM(354.71,IBX,0),"^",20)

                       DO BILL^IBARXMB(IB35471(.01),IB35471(.11))

                       QUIT 

 +20           SET HLERR="Transaction from local VistA or remote VA site"

           End DoDot:1

 +21      ;

 +22       QUIT 

 +23      ;

35471     ; files data into 354.71 (TYPE = IN)

 +1       ; validate data

 +2        NEW IBX,IBQ,IBRX,IBARXDAT,IBATYP,IBAM,IBDESC

 +3        IF '$LENGTH($TEXT(RPH^PSOPFSU0))

               SET HLERR="Pharmacy API not installed"

               QUIT 

 +4        SET IBQ=0

           FOR IBX=.01,.03,.05,.07,.08,.091,.1,.11,.12

               IF $GET(IB35471(IBX))=""

                   SET IBQ=1

                   QUIT 

 +5        IF IBQ

               SET HLERR="354.71 field "_IBX_" missing"

               QUIT 

 +6       ;

 +7        IF $PIECE($$SITE^VASITE,"^",3)'=+IB35471(.01)!(IB35471(.01)'?3N1"-"1N.N)

               SET HLERR="354.71 field .01 invalid"

               QUIT 

 +8        IF $PIECE($$SITE^VASITE,"^",3)'=+IB35471(.1)!(IB35471(.1)'?3N1"-"1N.N)

               SET HLERR="354.71 field .1 invalid"

               QUIT 

 +9        IF IB35471(.1)'=IB35471(.01)

               IF $ORDER(^IBAM(354.71,"B",IB35471(.1),0))

                   SET HLERR="354.71 field .1 is not a valid parent"

                   QUIT 

 +10       FOR IBX=.08,.11,.12

               SET IB35471(IBX)=+IB35471(IBX)

 +11       IF 'IB35471(.08)

               SET HLERR="Total Charge in-valid"

               QUIT 

 +12       SET IBRX=$ORDER(^PSRX("B",IB35471(.091),0))

           IF 'IBRX

               SET HLERR="Invalid prescription number"

               QUIT 

 +13       IF IB35471(.092)

               IF '$DATA(^PSRX(IBX,1,IB35471(.092),0))

                   SET HLERR="Invalid fill/refill number"

                   QUIT 

 +14       FOR IBX=.01,.03,.05,.07,.08,.11,.12

               DO CHK^DIE(354.71,IBX,,IB35471(IBX),.IBQ)

               IF IBQ="^"

                   SET HLERR="File 354.71, field "_IBX_" does not pass DD check"

                   QUIT 

 +15      ;

 +16      ;look up some needed rx data

 +17       SET IBARXDAT=$$RPH^PSOPFSU0(IBRX,+IB35471(.092))

 +18       IF $PIECE(IBARXDAT,"^",3)=""

               SET HLERR="Bad prescription data"

               QUIT 

 +19      ;

 +20      ;get brief description

 +21       SET IBX="52:"_IBRX_$SELECT(IB35471(.092):";1:"_IB35471(.092),1:"")_"^"_IB35471(.07)

 +22       DO ELIG^VADPT

           DO INP^VADPT

           DO DOM^IBARX

 +23       SET IBATYP=$ORDER(^IBE(350.1,"ANEW",$PIECE(IBARXDAT,"^",3),1,0))

 +24       DO BDESC^IBARX1

 +25      ;

 +26      ;need to set DUZ to pharmacy staff person who caused this to occur

 +27       Begin DoDot:1

 +28           IF $GET(DUZ)<1

                   NEW DUZ

                   SET DUZ=$SELECT(IB35471(.05)="NEW":$PIECE(IBARXDAT,"^"),1:$PIECE(IBARXDAT,"^",2))

                   SET DUZ(2)=+$$SITE^VASITE

 +29           NEW DIE,DR,DA

 +30      ;

 +31      ;file in 354.71

 +32           SET IBAM=$$ADD^IBARXMN(DFN,IB35471(.01)_"^"_DFN_"^"_IB35471(.03)_"^^"_IB35471(.05)_"^"_$PIECE(IBX,"^")_"^"_IB35471(.07)_"^"_IB35471(.08)_"^"_IBDESC_"^"_IB35471(.1)_"^"_IB35471(.11)_"^"_IB35471(.12)_"^"_$$LKUP^XUAF4(+IB35471(.01)),,1)

 +33           SET DIE="^IBAM(354.71,"

               SET DA=IBAM

               SET DR=".2////1"

               DO ^DIE

 +34      ;

 +35      ;call to send data to remote sites

 +36           DO FOUND^IBARXMA(.IBX,IBAM)

           End DoDot:1

 +37      ;

 +38       DO KVA^VADPT

 +39      ;

 +40       QUIT 

 +41      ;

351       ; files data in 351 (MT type)

 +1       ;

 +2        NEW IBQ,IBX,DIC,DIE,DR,X,Y,DA,DO

 +3       ;

 +4       ;validate data

 +5        SET IBQ=0

           FOR IBX=.03,.04,.05,.06,.07,.08,.09,.1

               IF $GET(IB351(IBX))=""

                   SET IBQ=1

                   QUIT 

 +6        IF IBQ

               SET HLERR="351 field "_IBX_" missing"

               QUIT 

 +7        IF '$GET(IB35471(.01))

               SET HLERR="Clock file number missing or invalid"

               QUIT 

 +8        SET IB351(.01)=IB35471(.01)

 +9        FOR IBX=.01,.03,.04,.05,.06,.07,.08,.09,.1

               DO CHK^DIE(351,IBX,,IB351(IBX),.IBQ)

               IF IBQ="^"

                   SET HLERR="File 351, field "_IBX_" does not pass DD check"

                   QUIT 

 +10      ;

 +11      ; see if clock already exists or add

 +12       SET IBX=$ORDER(^IBE(351,"B",IB35471(.01),0))

 +13       IF 'IBX

               SET DIC="^IBE(351,"

               SET X=IB351(.01)

               SET DIC(0)=""

               SET DIC("DR")=".02////^S X=DFN;11////"_$SELECT($DATA(DUZ):DUZ,1:.5)_";12///NOW;13////"_$SELECT($DATA(DUZ):DUZ,1:.5)_";14///NOW"

               KILL DO

               DO FILE^DICN

               SET IBX=+Y

 +14       IF DFN'=$PIECE($GET(^IBE(351,IBX,0)),"^",2)

               SET HLERR="Patient does not match clock file entry"

               QUIT 

 +15      ;

 +16      ; file data received

 +17       SET DIE="^IBE(351,"

           SET DA=IBX

           SET DR=".04///^S X=IB351(.04);13////"_$SELECT($DATA(DUZ):DUZ,1:.5)_";14///NOW"

           FOR X=.03,.05,.06,.07,.08,.09,.1

               SET DR=DR_";"_X_"////"_+IB351(X)

 +18       DO ^DIE

 +19       QUIT 

 +20      ;

35181     ; files data in 351.81 (LB type)

 +1       ;

 +2        NEW IBQ,IBX,DIC,DIE,DR,X,Y,IBY,DA,DO,DIK,IBLTCX

 +3       ;

 +4       ;validate data

 +5        SET IBQ=0

           FOR IBX=.03,.04,.05

               IF $GET(IB35181(IBX))=""

                   SET IBQ=1

                   QUIT 

 +6        IF IBQ

               SET HLERR="351.81 field "_IBX_" missing"

               QUIT 

 +7        IF '$GET(IB35471(.01))

               SET HLERR="LTC Clock file number missing or invalid"

               QUIT 

 +8        SET IB35181(.01)=IB35471(.01)

 +9        FOR IBX=.01,.03,.04,.05

               DO CHK^DIE(351.81,IBX,,IB35181(IBX),.IBQ)

               IF IBQ="^"

                   SET HLERR="File 351.81, field "_IBX_" does not pass DD check"

                   QUIT 

 +10       SET IBX=0

           FOR 

               SET IBX=$ORDER(IBMTDT21(IBX))

               if 'IBX

                   QUIT 

               DO CHK^DIE(351.811,.02,,IBMTDT21(IBX),.IBQ)

               IF IBQ="^"

                   SET HLERR="LTC Exempt date "_IBMTDT21(IBX)_" does not pass DD check"

                   QUIT 

 +11      ;

 +12      ; see if clock already exists or add

 +13       SET IBX=$ORDER(^IBA(351.81,"B",IB35181(.01),0))

 +14       IF 'IBX

               SET DIC="^IBA(351.81,"

               SET X=IB35181(.01)

               SET DIC(0)=""

               SET DIC("DR")=".02////^S X=DFN;4.01////"_$SELECT($DATA(DUZ):DUZ,1:.5)_";4.02///NOW;4.03////"_$SELECT($DATA(DUZ):DUZ,1:.5)_";4.04///NOW"

               KILL DO

               DO FILE^DICN

               SET IBX=+Y

 +15       IF DFN'=$PIECE($GET(^IBA(351.81,IBX,0)),"^",2)

               SET HLERR="Patient does not match LTC clock file entry"

               QUIT 

 +16      ;

 +17      ; file top level file data received

 +18       SET DIE="^IBA(351.81,"

           SET DA=IBX

           SET DR="4.03////"_$SELECT($DATA(DUZ):DUZ,1:.5)_";4.04///NOW"

           FOR X=.03,.04,.05

               SET DR=DR_";"_X_"////"_+IB35181(X)

 +19       DO ^DIE

 +20      ;

 +21      ; clean out 21 days and re-file based on data received

 +22       SET DIK="^IBA(351.81,"_IBX_",1,"

           SET DA(1)=IBX

           SET IBY=0

           FOR 

               SET IBY=$ORDER(^IBA(351.81,IBX,1,IBY))

               if 'IBY

                   QUIT 

               SET DA=IBY

               DO ^DIK

 +23       SET DIC=DIK

           SET DIC(0)=""

           SET IBY=0

           FOR 

               SET IBY=$ORDER(IBMTDT21(IBY))

               if 'IBY

                   QUIT 

               SET X=IBY

               SET DIC("DR")=".02////^S X=IBMTDT21(IBY)"

               KILL DO

               DO FILE^DICN

 +24       SET IBLTCX=IBX

           DO REINDEX^IBAECC

 +25      ;

 +26       QUIT 

 +27      ;

350       ; files data in 350 (ML type)

 +1        NEW IBQ,IBX,DIC,DIE,DR,X,Y,IBY,DA,DO,IBDESC

 +2       ;

 +3       ; do i have data

 +4        SET IBQ=0

           FOR IBX="TYP","IO","BS","EDT",.06,.07,.17,.14,.15,.05,"IDX"

               IF $GET(IB350(IBX))=""

                   SET IBQ=1

                   QUIT 

 +5        IF IBQ

               SET HLERR="350 field "_IBX_" missing"

               QUIT 

 +6        IF $GET(IB35471(.01))=""

               SET HLERR="350 field .01 mssing"

               QUIT 

 +7       ;

 +8       ;determine action type

 +9        SET IB350(.03)=$$ATYPE(IB350("TYP"),IB350("IO"),IB350("BS"))

           IF IB350(.03)=-1

               SET HLERR="Unable to determine Action Type"

               QUIT 

 +10       SET IB350(.03)=$ORDER(^IBE(350.1,"B",IB350(.03),0))

           IF 'IB350(.03)

               SET HLERR="Action Type not found in 350.1"

               QUIT 

 +11      ;

 +12      ;determine brief description if any

 +13       IF $DATA(^IBE(350.1,IB350(.03),20))

               XECUTE ^(20)

 +14      ;

 +15      ;determine institution (defualt to here if not known)

 +16       SET IB350(.13)=$SELECT($DATA(IBINST):$$LKUP^XUAF4(IBINST),1:+$$SITE^VASITE)

 +17      ;

 +18      ;determine clinic stop if needed

 +19       IF IB350("IO")="O"

               SET IB350(.2)=$$GET3525^IBEMTSCU($EXTRACT($GET(IB350(.2)),1,3),$EXTRACT($GET(IB350(.2)),4,6),IB350(.17))

               IF 'IB350(.2)

                   SET HLERR="Unable to find valid clinic stop code in 352.5"

                   QUIT 

 +20      ;

 +21      ;check out data

 +22       SET IB350(.01)=IB35471(.01)

 +23       FOR IBX=.01,.06,.07,.17,.14,.15,.05

               DO CHK^DIE(350,IBX,,IB350(IBX),.IBQ)

               IF IBQ="^"

                   SET HLERR="File 350, field "_IBX_" does not pass DD check"

                   QUIT 

 +24       IF $LENGTH($GET(HLERR))

               QUIT 

 +25       SET IB350(.22)=$ORDER(^IBBAA(375,"C",IB350("IDX"),0))

           IF 'IB350(.22)

               SET HLERR="PFSS Account Number not found"

               QUIT 

 +26      ;

 +27      ;see if already exists or add

 +28       SET IBX=$ORDER(^IB("B",IB350(.01),0))

 +29       IF 'IBX

               SET DIC="^IB("

               SET X=IB350(.01)

               SET DIC(0)=""

               SET DIC("DR")=".02////^S X=DFN;11////"_$SELECT($DATA(DUZ):DUZ,1:.5)_";12///NOW;13////"_$SELECT($DATA(DUZ):DUZ,1:.5)_";14///NOW"

               KILL DO

               DO FILE^DICN

               SET IBX=+Y

 +30       IF DFN'=$PIECE($GET(^IB(IBX,0)),"^",2)

               SET HLERR="Patient does not match IB file entry"

               QUIT 

 +31      ;

 +32      ;file data

 +33       SET DIE="^IB("

           SET DA=IBX

           SET DR=".05///^S X=IB350(.05);13////"_$SELECT($DATA(DUZ):DUZ,1:.5)_";14///NOW"_$SELECT(IB350("IO")="O":";.2////^S X=IB350(.2)",1:"")_$SELECT($DATA(IBDESC):";.08////^S X=IBDESC",1:"")

 +34       FOR IBY=.03,.06,.07,.13,.17,.14,.15,.22

               if '$LENGTH($PIECE(^IB(IBX,0),"^",IBY*100))

                   SET DR=DR_";"_IBY_"////"_(+IB350(IBY))

 +35       DO ^DIE

 +36      ;

 +37       QUIT 

 +38      ;

ERR       ; trans type not found, set error

 +1        SET HLERR="Transaction Type field not valid (.6)."

 +2        QUIT 

 +3       ;

ATYPE(IBTYP,IBIO,IBBS) ; used to determine action type

 +1        IF IBTYP="MT"

               IF IBIO="O"

                   QUIT "DG OPT COPAY NEW"

 +2        IF IBTYP="MT"

               IF IBIO="I"

                   QUIT "DG INPT COPAY ("_IBBS_") NEW"

 +3        IF IBTYP="GMT"

               IF IBIO="I"

                   QUIT "DG INPT COPAY ("_IBBS_") NEW"

 +4        IF IBTYP="LTC"

               IF IBIO="O"

                   QUIT "DG LTC OPT "_IBBS_" NEW"

 +5        IF IBTYP="LTC"

               IF IBIO="I"

                   QUIT "DG LTC INPT "_IBBS_" NEW"

 +6        IF IBTYP="FEE"

               IF IBIO="O"

                   QUIT "DG FEE SERVICE (OPT) NEW"

 +7        IF IBTYP="FEE"

               IF IBIO="I"

                   QUIT "DG FEE SERVICE (INPT) NEW"

 +8        IF IBTYP="LTC FEE"