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 ---[H[J[2J[HIBARXMI 9786 printed Dec 13, 2024@02:07:33 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"
IF IBIO="O"
QUIT "DG LTC FEE OPT "_IBBS_" NEW"
+9 IF IBTYP="LTC FEE"
IF IBIO="I"
QUIT "DG LTC FEE INPT "_IBBS_" NEW"
+10 IF IBTYP="MT PERDIEM"
QUIT "DG INPT PER DIEM NEW"
+11 IF IBTYP="MT"
IF IBBS="OBS"
QUIT "DG OBSERVATION COPAY NEW"
+12 IF IBTYP="CHAMPUS"
IF IBIO="O"
QUIT "DG TRICARE OPT COPAY NEW"
+13 IF IBTYP="CHAMPUS"
IF IBIO="I"
QUIT "DG TRICARE INPT COPAY NEW"
+14 QUIT -1
+15 ;
