ABSPOSBM ; IHS/FCS/DRS - POS billing, part 3 ;
;;1.0;PHARMACY POINT OF SALE;**48**;JUN 21, 2001;Build 38
; *****
; ***** Interface to ABSB, the ILC A/R package
; ***** This code is reached _ONLY_ by sites using ILC A/R,
; ***** and who choose to interface to it.
; *****
Q
CHGLIST() ; EP - from ABSPOSBX
; Post all the charges in CHGLIST(IEN57)="" ; returns PCNDFN
K ^BLL($J),^TMP($J,"VCPT")
N VSTDFN,VCN
N IEN57 S IEN57=$O(CHGLIST(0))
S VSTDFN=$$VISITIEN^ABSPOS57
I 'VSTDFN D IMPOSS^ABSPOSUE("DB","TI","Missing visit pointer","IEN57="_IEN57,"CHGLIST",$T(+0))
S VCN=$P($G(^AUPNVSIT(VSTDFN,"VCN")),U)
I VCN="" D IMPOSS^ABSPOSUE("DB","TI","Missing VCN","VSTDFN="_VSTDFN,"CHGLIST",$T(+0))
S IEN57=0 F S IEN57=$O(CHGLIST(IEN57)) Q:'IEN57 D
. N VCPT
. S VCPT=$$VCPT^ABSPOSBV
. S ^BLL($J,VCN,VCPT)=""
. S ^TMP($J,"VCPT",VCPT)=IEN57_U_$$RXI^ABSPOS57_U_$$RXR^ABSPOS57
D LOG^ABSPOSL($T(+0)_" - Posting for VCN="_VCN_", VSTDFN="_VSTDFN)
;
; Make sure the visit has a V68.1 diagnosis code
; (special for Sitka; available to others)
;
I '$P($G(^ABSP(9002313.99,1,"CREATING A/R")),U,1) D
. D V681^ABSPOSB3
;
; Make sure the visit has a primary provider, setting him to
; be the prescriber if none is already defined.
; (Special for Sitka; available to others)
;
I '$P($G(^ABSP(9002313.99,1,"CREATING A/R")),U,2) D
. D PROVIDER^ABSPOSB3()
;
; Make sure the visit has a clinic. If not, give it the PHARMACY..
;
I '$P($G(^ABSP(9002313.99,1,"CREATING A/R")),U,3) D
. D CLINIC^ABSPOSB3
;
; Finally, create the actual bill
;
N PCNDFN
S PCNDFN=$$ABSBMAKE
I '$G(PCNDFN) D
. D LOG^ABSPOSL($T(+0)_" - ABSBMAKE failed to post charges!!")
. D IMPOSS^ABSPOSUE("P,DB","TI",,,"call to ^ABSBMAKE",$T(+0))
;
D DTBILLED ; And update the DATE BILLED multiple
D COMMENTS ; about how much was paid and about reasons for rejects
Q PCNDFN
N ARRPAID,ARRREJ ;
S IEN57=0 F S IEN57=$O(CHGLIST(IEN57)) Q:'IEN57 D
. N R S R=$$GET1^DIQ(9002313.57,IEN57_",","RESULT WITH REVERSAL")
. I R="E PAYABLE" S ARRPAID(IEN57)=""
. E I R="E REJECTED" S ARRREJ(IEN57)=""
I $D(ARRPAID) D PAYABLE^ABSPOSBF(PCNDFN,"Insurer will pay",.ARRPAID)
I $D(ARRREJ) D REJECTS^ABSPOSBF(PCNDFN,"Rejected claims",.ARRREJ)
Q
DTBILLED ; Update the DATE BILLED multiple
N FDA,MSG,IEN57 S IEN57=$O(CHGLIST(0))
N FN,IENS S FN=9002302.04,IENS="+1,"_PCNDFN_","
S FDA(FN,IENS,.01)=DT ; DATE BILLED
N IDLIST,AMT,IEN57 S IEN57=0
F S IEN57=$O(CHGLIST(IEN57)) Q:IEN57="" D
. ; if it has a claim ID, it was billed electronically
. N X S X=$P(^ABSPTL(IEN57,0),U,4) Q:'X
. S IDLIST($P(^ABSPC(X,0),U))=""
. S AMT=AMT+$P(^ABSPTL(IEN57,5),U,5)
. S FDA(FN,IENS,.02)=$$FMTIDS ; DESCRIPTION
I $G(FDA(FN,IENS,.02))="" Q ; none of them sent electronically
S FDA(FN,IENS,.03)=AMT ; AMOUNT BILLED
S FDA(FN,IENS,.04)=$$INSIEN^ABSPOS57
DTB8 D UPDATE^DIE(,"FDA",,"MSG")
I $D(MSG) D LOG^ABSPOSL2("F^ABSPOSBX",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
I $D(MSG) D G DTB8:$$IMPOSS^ABSPOSUE("FM","TRI",$T(DTBILLED),,"DTB8",$T(+0))
. D LOG^ABSPOSL("Failed to update DATE BILLED")
. D LOGARRAY^ABSPOSL("FDA")
. D LOGARRAY^ABSPOSL("MSG")
Q
FMTIDS() ; format IDLIST(claim ID's) into a concise string
; LEN agrees with ^DD(9002302.04,1) maximum length
N X,RET,LEN,FIRST S (FIRST,RET,X)=$O(IDLIST("")),LEN=50
F S X=$O(IDLIST(X)) Q:X="" D
. I $P(X,"-",1,2)=$P(FIRST,"-",1,2) S RET=RET_","_$P(X,"-",3)
. E S RET=RET_";"_X,FIRST=X
I $L(RET)>LEN S RET=$E(RET,1,LEN-3)_"..."
E I $L(RET)+4'>LEN S RET="POS "_RET
Q RET
ABSBMAKE() ;
; We have ^BLL, ^TMP as above; also VCN,VSTDFN and lots of other stuff
; Return PCNDFN
N ARTYPNUM D ARTYPNUM ; set the right ARTYPNUM for these charges
I $D(^AUPNVSIT(VSTDFN,"PINS")) S ^TMP($J,"SAVE PINS")=^AUPNVSIT(VSTDFN,"PINS")
E K ^TMP($J,"SAVE PINS")
I $D(^AUPNVSIT(VSTDFN,"PCN")) S ^TMP($J,"SAVE PCN")=^AUPNVSIT(VSTDFN,"PCN")
E K ^TMP($J,"SAVE PCN")
N PINS D PINS
D ; fix old style CAID,2352 -> CAID,2352,0
. ; affects only those created under old and being posted under new
. N I F I=1:1:$L(PINS,U) D
. . N X S X=$P(PINS,U,I)
. . I $L(X,",")=2 S $P(X,",",3)=0,$P(PINS,U,I)=X
S ^AUPNVSIT(VSTDFN,"PINS")=PINS
S $P(^AUPNVSIT(VSTDFN,"PCN"),U)=ARTYPNUM
N PCN,BAL,PCNDFN
D
. N BLLTYP S BLLTYP="OP"
. N FIXINDEX S FIXINDEX=0
. I '$O(^AUPNVSIT("VCN",VCN,"")) D
. . D LOG^ABSPOSL("DELETED VISIT FOR "_VCN_" INTERNAL NUMBER "_VSTDFN)
. . D LOG^ABSPOSL("We're going to post charges to it anyway.")
. . S ^AUPNVSIT("VCN",VCN,VSTDFN)=""
. . S FIXINDEX=1
. ;D LOG^ABSPOSB3("with ^AUPNVSIT("_VSTDFN_",""PINS"")="_$G(^AUPNVSIT(VSTDFN,"PINS")))
. ; Use the "null file" for ^ABSBMAKE output
AM6 . I '$$NULLOPEN D G AM6:$$IMPOSS^ABSPOSUE("DEV","IRT","$$NULLOPEN",,"AM6",$T(+0))
. D COMBINS ; - - - - - - - UPDATE COMBINED INSURANCE - - - - - - -
. D ^ABSBMAKE ; - - - - - - - - - CREATE THE BILL - - - - - - - -
. D NULLCLOS
. I FIXINDEX D
. . K ^AUPNVSIT("VCN",VCN,VSTDFN)
. S PCN=$P(^ABSBITMS(9002302,PCNDFN,0),U)
. S BAL=$P(^ABSBITMS(9002302,PCNDFN,3),U)
; restore the old PINS and PCN TYPE to the visit
I $D(^TMP($J,"SAVE PINS")) S ^AUPNVSIT(VSTDFN,"PINS")=^TMP($J,"SAVE PINS") K ^TMP($J,"SAVE PINS")
E K ^AUPNVSIT(VSTDFN,"PINS")
I $D(^TMP($J,"SAVE PCN")) S ^AUPNVSIT(VSTDFN,"PCN")=^TMP($J,"SAVE PCN")
E K ^AUPNVSIT(VSTDFN,"PCN")
I '$G(PCNDFN) D Q ""
. D LOG^ABSPOSL("* * * * * ERROR: did not create A/R for VN="_VCN_",VSTDFN="_VSTDFN)
. D LOG^ABSPOSL("This is the ^BLL($J) contents:")
. N TMP M TMP=^BLL($J)
. D LOGARRAY^ABSPOSL("TMP")
. D LOG^ABSPOSL("This is the ^TMP($J,""VCPT"") contents:")
. K TMP M TMP=^TMP($J,"VCPT")
. D LOGARRAY^ABSPOSL("TMP")
N PAT D
. N N D FIRSTN
. S PAT=$P(^ABSPTL(N,0),U,6)
. S PAT=$P(^DPT(PAT,0),U)
N X S X=PAT_" VCN "_VCN_" PCN "_PCN
S X=X_" $"_$J(BAL,0,2)
S X=X_" posted"
D LOG^ABSPOSL(X) ;,$G(ECHO))
N VCPT S VCPT=0 F S VCPT=$O(^BLL($J,VCN,VCPT)) Q:'VCPT D
. N N,RXI,RXR
. S N=^TMP($J,"VCPT",VCPT),RXI=$P(N,U,2),RXR=$P(N,U,3),N=$P(N,U)
. N N57 S N57=N ; maybe, in case fileman blows away N
. D LINEITEM ; log file detail of the charge
. D MARKVCPT ; note RXI, RXR on the VCPT
. D UPDATE57 ; record in .57 file that this entry has been billed
. D UPDATE02 ; 9002313.02 claim points to PCN
. I $$GET1^DIQ(9002313.57,N57_",","RESULT WITH REVERSAL")?1"E ".E D
. . D OFFNCPDP^ABSBPBRX(PCNDFN) ; electronic claim? do not print form.
Q PCNDFN
COMBINS ; have to update the combined insurance file? Yes.
; because DO ^ABSBMAKE refers back to combined insurance.
; (This is new. Sitka didn't need it because back then,
; ILC and Point of Sale used the same ^ABSBCOMB.)
N PATDFN S PATDFN=$P(^AUPNVSIT(VSTDFN,0),U,5)
I $D(^ABSBCOMB) D ; FSI/ILC A/R Version 2
. D EN^VTLCOMB(PATDFN)
E D ; FSI/ILC A/R Version 1
. N D1,ELGBEG,ELGEND,GRPDFN,GRPNAM,GRPNUM,INSDFN,INSNAM
. N POLDFN,POLNAM,POLNUM,POLREC,REC,REL,X
. D ^ABSBCOMB(PATDFN)
Q
LINEITEM ;
N DRGDFN,NDC,DRGNAME,CHARGE,X,QTY
S DRGDFN=$P(^PSRX(RXI,0),U,6)
S NDC=$P(^ABSPTL(N57,1),U,2) ; fixed 03/26/2001
S DRGNAME=$P($G(^PSDRUG(DRGDFN,0)),U)
S CHARGE=$P(^ABSVCPT(9002301,VCPT,0),U,5)
S QTY=$P(^ABSPTL(N57,5),U)
I QTY#1 S QTY=$J(QTY,8,3)
E S QTY=$J(QTY,4)
S X=QTY_" "_$$ANFF^ABSPECFM(DRGNAME,25)_" "
S X=X_$$ANFF^ABSPECFM($$FORMTNDC^ABSPOS9(NDC),13)
S X=X_" "_$J(CHARGE,8,2)
S X=X_" ("_VCPT_")"
D LOG^ABSPOSL(X)
Q
MARKVCPT ;
N DIE,DA,DR,DIDEL,DTOUT
S DIE=9002301,DA=VCPT,DR="56////"_RXI_";56.3////"_RXR_";56.4////"_N57
D ^DIE
Q
UPDATE57 ; record in POS data that this VCPT has been billed
N DIE,DA,DR,DIDEL,DTOUT
S DIE=9002313.57,DA=N57,DR="2////"_PCNDFN D ^DIE
Q
Q
UPDATE02 ;
N DIE,DA,DR,DIDEL,DTOUT
S DIE=9002313.02,DA=$P(^ABSPTL(N57,0),U,4)
Q:'DA
S DR=".03////"_PCNDFN_";1.02///"_PCN_";1.03///"_VCN
D ^DIE
Q
ARTYPNUM ; determine the AR TYPE number for the current VCN
N OK,PHARM
ART2 S OK=1
D FIRSTN
S PHARM=$P(^ABSPTL(N,1),U,7) ; point to .56
S ARTYPNUM=$P(^ABSP(9002313.56,PHARM,0),U,4)
I 'ARTYPNUM S ARTYPNUM=$P(^ABSP(9002313.99,1,"RX A/R TYPE"),U)
I 'ARTYPNUM S OK=0
I OK I '$D(^ABSBTYP(ARTYPNUM)) S OK=0 ; be overly cautious about this
I 'OK G ART2:$$IMPOSS^ABSPOSUE("DB","RTI","A/R TYPE missing from setup file",,"ARTYPNUM",$T(+0))
Q
PINS ; set PINS = the right PINS node for this VCN
D FIRSTN
S PINS=^ABSPTL(N,6)
Q
FIRSTN ; S N=first 9002313.57 for the first VCPT for this VCN
; used by ARTYPNUM and PINS
N VCPT S VCPT=$O(^BLL($J,VCN,0))
I 'VCPT D Q ; get first VCPT
. D IMPOSS^ABSPOSUE("P","TI","Incomplete ^BLL array",,"FIRSTN",$T(+0))
S N=$P(^TMP($J,"VCPT",VCPT),U) ; point to the 9002313.57 record
Q
NULLOPEN() ; open null file, because ^ABSBMAKE echoes to screen
S X=$$GET1^DIQ(9002313.99,"1,",1490)
N DIR,FILE,SLASH,SLASHCH
S SLASH=$S(X["/":"/",X["\":"\",1:"")
I SLASH]"" D
. N N S N=$L(X,SLASH)
. S DIR=$P(X,SLASH,1,N-1)_SLASH
. S FILE=$P(X,SLASH,N)
E D
. I X="" S DIR="",FILE=$T(+0)_".tmp"
. E S DIR="",FILE=X
D OPEN^%ZISH($$NULLHNDL,DIR,FILE,"W")
Q '$G(POP) ; 1 success, 0 failure
NULLCLOS D CLOSE^%ZISH($$NULLHNDL) Q
NULLHNDL() Q 54
ABSPOSBM ; IHS/FCS/DRS - POS billing, part 3 ;
+1 ;;1.0;PHARMACY POINT OF SALE;**48**;JUN 21, 2001;Build 38
+2 ; *****
+3 ; ***** Interface to ABSB, the ILC A/R package
+4 ; ***** This code is reached _ONLY_ by sites using ILC A/R,
+5 ; ***** and who choose to interface to it.
+6 ; *****
+7 QUIT
CHGLIST() ; EP - from ABSPOSBX
+1 ; Post all the charges in CHGLIST(IEN57)="" ; returns PCNDFN
+2 KILL ^BLL($JOB),^TMP($JOB,"VCPT")
+3 NEW VSTDFN,VCN
+4 NEW IEN57
SET IEN57=$ORDER(CHGLIST(0))
+5 SET VSTDFN=$$VISITIEN^ABSPOS57
+6 IF 'VSTDFN
DO IMPOSS^ABSPOSUE("DB","TI","Missing visit pointer","IEN57="_IEN57,"CHGLIST",$TEXT(+0))
+7 SET VCN=$PIECE($GET(^AUPNVSIT(VSTDFN,"VCN")),U)
+8 IF VCN=""
DO IMPOSS^ABSPOSUE("DB","TI","Missing VCN","VSTDFN="_VSTDFN,"CHGLIST",$TEXT(+0))
+9 SET IEN57=0
FOR
SET IEN57=$ORDER(CHGLIST(IEN57))
IF 'IEN57
QUIT
Begin DoDot:1
+10 NEW VCPT
+11 SET VCPT=$$VCPT^ABSPOSBV
+12 SET ^BLL($JOB,VCN,VCPT)=""
+13 SET ^TMP($JOB,"VCPT",VCPT)=IEN57_U_$$RXI^ABSPOS57_U_$$RXR^ABSPOS57
End DoDot:1
+14 DO LOG^ABSPOSL($TEXT(+0)_" - Posting for VCN="_VCN_", VSTDFN="_VSTDFN)
+15 ;
+16 ; Make sure the visit has a V68.1 diagnosis code
+17 ; (special for Sitka; available to others)
+18 ;
+19 IF '$PIECE($GET(^ABSP(9002313.99,1,"CREATING A/R")),U,1)
Begin DoDot:1
+20 DO V681^ABSPOSB3
End DoDot:1
+21 ;
+22 ; Make sure the visit has a primary provider, setting him to
+23 ; be the prescriber if none is already defined.
+24 ; (Special for Sitka; available to others)
+25 ;
+26 IF '$PIECE($GET(^ABSP(9002313.99,1,"CREATING A/R")),U,2)
Begin DoDot:1
+27 DO PROVIDER^ABSPOSB3()
End DoDot:1
+28 ;
+29 ; Make sure the visit has a clinic. If not, give it the PHARMACY..
+30 ;
+31 IF '$PIECE($GET(^ABSP(9002313.99,1,"CREATING A/R")),U,3)
Begin DoDot:1
+32 DO CLINIC^ABSPOSB3
End DoDot:1
+33 ;
+34 ; Finally, create the actual bill
+35 ;
+36 NEW PCNDFN
+37 SET PCNDFN=$$ABSBMAKE
+38 IF '$GET(PCNDFN)
Begin DoDot:1
+39 DO LOG^ABSPOSL($TEXT(+0)_" - ABSBMAKE failed to post charges!!")
+40 DO IMPOSS^ABSPOSUE("P,DB","TI",,,"call to ^ABSBMAKE",$TEXT(+0))
End DoDot:1
+41 ;
+42 ; And update the DATE BILLED multiple
DO DTBILLED
+43 ; about how much was paid and about reasons for rejects
DO COMMENTS
+44 QUIT PCNDFN
+1 ;
NEW ARRPAID,ARRREJ
+2 SET IEN57=0
FOR
SET IEN57=$ORDER(CHGLIST(IEN57))
IF 'IEN57
QUIT
Begin DoDot:1
+3 NEW R
SET R=$$GET1^DIQ(9002313.57,IEN57_",","RESULT WITH REVERSAL")
+4 IF R="E PAYABLE"
SET ARRPAID(IEN57)=""
+5 IF '$TEST
IF R="E REJECTED"
SET ARRREJ(IEN57)=""
End DoDot:1
+6 IF $DATA(ARRPAID)
DO PAYABLE^ABSPOSBF(PCNDFN,"Insurer will pay",.ARRPAID)
+7 IF $DATA(ARRREJ)
DO REJECTS^ABSPOSBF(PCNDFN,"Rejected claims",.ARRREJ)
+8 QUIT
DTBILLED ; Update the DATE BILLED multiple
+1 NEW FDA,MSG,IEN57
SET IEN57=$ORDER(CHGLIST(0))
+2 NEW FN,IENS
SET FN=9002302.04
SET IENS="+1,"_PCNDFN_","
+3 ; DATE BILLED
SET FDA(FN,IENS,.01)=DT
+4 NEW IDLIST,AMT,IEN57
SET IEN57=0
+5 FOR
SET IEN57=$ORDER(CHGLIST(IEN57))
IF IEN57=""
QUIT
Begin DoDot:1
+6 ; if it has a claim ID, it was billed electronically
+7 NEW X
SET X=$PIECE(^ABSPTL(IEN57,0),U,4)
IF 'X
QUIT
+8 SET IDLIST($PIECE(^ABSPC(X,0),U))=""
+9 SET AMT=AMT+$PIECE(^ABSPTL(IEN57,5),U,5)
+10 ; DESCRIPTION
SET FDA(FN,IENS,.02)=$$FMTIDS
End DoDot:1
+11 ; none of them sent electronically
IF $GET(FDA(FN,IENS,.02))=""
QUIT
+12 ; AMOUNT BILLED
SET FDA(FN,IENS,.03)=AMT
+13 SET FDA(FN,IENS,.04)=$$INSIEN^ABSPOS57
DTB8 DO UPDATE^DIE(,"FDA",,"MSG")
+1 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("F^ABSPOSBX",.MSG)
+2 IF $DATA(MSG)
Begin DoDot:1
+3 DO LOG^ABSPOSL("Failed to update DATE BILLED")
+4 DO LOGARRAY^ABSPOSL("FDA")
+5 DO LOGARRAY^ABSPOSL("MSG")
End DoDot:1
IF $$IMPOSS^ABSPOSUE("FM","TRI",$TEXT(DTBILLED),,"DTB8",$TEXT(+0))
GOTO DTB8
+6 QUIT
FMTIDS() ; format IDLIST(claim ID's) into a concise string
+1 ; LEN agrees with ^DD(9002302.04,1) maximum length
+2 NEW X,RET,LEN,FIRST
SET (FIRST,RET,X)=$ORDER(IDLIST(""))
SET LEN=50
+3 FOR
SET X=$ORDER(IDLIST(X))
IF X=""
QUIT
Begin DoDot:1
+4 IF $PIECE(X,"-",1,2)=$PIECE(FIRST,"-",1,2)
SET RET=RET_","_$PIECE(X,"-",3)
+5 IF '$TEST
SET RET=RET_";"_X
SET FIRST=X
End DoDot:1
+6 IF $LENGTH(RET)>LEN
SET RET=$EXTRACT(RET,1,LEN-3)_"..."
+7 IF '$TEST
IF $LENGTH(RET)+4'>LEN
SET RET="POS "_RET
+8 QUIT RET
ABSBMAKE() ;
+1 ; We have ^BLL, ^TMP as above; also VCN,VSTDFN and lots of other stuff
+2 ; Return PCNDFN
+3 ; set the right ARTYPNUM for these charges
NEW ARTYPNUM
DO ARTYPNUM
+4 IF $DATA(^AUPNVSIT(VSTDFN,"PINS"))
SET ^TMP($JOB,"SAVE PINS")=^AUPNVSIT(VSTDFN,"PINS")
+5 IF '$TEST
KILL ^TMP($JOB,"SAVE PINS")
+6 IF $DATA(^AUPNVSIT(VSTDFN,"PCN"))
SET ^TMP($JOB,"SAVE PCN")=^AUPNVSIT(VSTDFN,"PCN")
+7 IF '$TEST
KILL ^TMP($JOB,"SAVE PCN")
+8 NEW PINS
DO PINS
+9 ; fix old style CAID,2352 -> CAID,2352,0
Begin DoDot:1
+10 ; affects only those created under old and being posted under new
+11 NEW I
FOR I=1:1:$LENGTH(PINS,U)
Begin DoDot:2
+12 NEW X
SET X=$PIECE(PINS,U,I)
+13 IF $LENGTH(X,",")=2
SET $PIECE(X,",",3)=0
SET $PIECE(PINS,U,I)=X
End DoDot:2
End DoDot:1
+14 SET ^AUPNVSIT(VSTDFN,"PINS")=PINS
+15 SET $PIECE(^AUPNVSIT(VSTDFN,"PCN"),U)=ARTYPNUM
+16 NEW PCN,BAL,PCNDFN
+17 Begin DoDot:1
+18 NEW BLLTYP
SET BLLTYP="OP"
+19 NEW FIXINDEX
SET FIXINDEX=0
+20 IF '$ORDER(^AUPNVSIT("VCN",VCN,""))
Begin DoDot:2
+21 DO LOG^ABSPOSL("DELETED VISIT FOR "_VCN_" INTERNAL NUMBER "_VSTDFN)
+22 DO LOG^ABSPOSL("We're going to post charges to it anyway.")
+23 SET ^AUPNVSIT("VCN",VCN,VSTDFN)=""
+24 SET FIXINDEX=1
End DoDot:2
+25 ;D LOG^ABSPOSB3("with ^AUPNVSIT("_VSTDFN_",""PINS"")="_$G(^AUPNVSIT(VSTDFN,"PINS")))
+26 ; Use the "null file" for ^ABSBMAKE output
AM6 IF '$$NULLOPEN
Begin DoDot:2
End DoDot:2
IF $$IMPOSS^ABSPOSUE("DEV","IRT","$$NULLOPEN",,"AM6",$TEXT(+0))
GOTO AM6
+1 ; - - - - - - - UPDATE COMBINED INSURANCE - - - - - - -
DO COMBINS
+2 ; - - - - - - - - - CREATE THE BILL - - - - - - - -
DO ^ABSBMAKE
+3 DO NULLCLOS
+4 IF FIXINDEX
Begin DoDot:2
+5 KILL ^AUPNVSIT("VCN",VCN,VSTDFN)
End DoDot:2
+6 SET PCN=$PIECE(^ABSBITMS(9002302,PCNDFN,0),U)
+7 SET BAL=$PIECE(^ABSBITMS(9002302,PCNDFN,3),U)
End DoDot:1
+8 ; restore the old PINS and PCN TYPE to the visit
+9 IF $DATA(^TMP($JOB,"SAVE PINS"))
SET ^AUPNVSIT(VSTDFN,"PINS")=^TMP($JOB,"SAVE PINS")
KILL ^TMP($JOB,"SAVE PINS")
+10 IF '$TEST
KILL ^AUPNVSIT(VSTDFN,"PINS")
+11 IF $DATA(^TMP($JOB,"SAVE PCN"))
SET ^AUPNVSIT(VSTDFN,"PCN")=^TMP($JOB,"SAVE PCN")
+12 IF '$TEST
KILL ^AUPNVSIT(VSTDFN,"PCN")
+13 IF '$GET(PCNDFN)
Begin DoDot:1
+14 DO LOG^ABSPOSL("* * * * * ERROR: did not create A/R for VN="_VCN_",VSTDFN="_VSTDFN)
+15 DO LOG^ABSPOSL("This is the ^BLL($J) contents:")
+16 NEW TMP
MERGE TMP=^BLL($JOB)
+17 DO LOGARRAY^ABSPOSL("TMP")
+18 DO LOG^ABSPOSL("This is the ^TMP($J,""VCPT"") contents:")
+19 KILL TMP
MERGE TMP=^TMP($JOB,"VCPT")
+20 DO LOGARRAY^ABSPOSL("TMP")
End DoDot:1
QUIT ""
+21 NEW PAT
Begin DoDot:1
+22 NEW N
DO FIRSTN
+23 SET PAT=$PIECE(^ABSPTL(N,0),U,6)
+24 SET PAT=$PIECE(^DPT(PAT,0),U)
End DoDot:1
+25 NEW X
SET X=PAT_" VCN "_VCN_" PCN "_PCN
+26 SET X=X_" $"_$JUSTIFY(BAL,0,2)
+27 SET X=X_" posted"
+28 ;,$G(ECHO))
DO LOG^ABSPOSL(X)
+29 NEW VCPT
SET VCPT=0
FOR
SET VCPT=$ORDER(^BLL($JOB,VCN,VCPT))
IF 'VCPT
QUIT
Begin DoDot:1
+30 NEW N,RXI,RXR
+31 SET N=^TMP($JOB,"VCPT",VCPT)
SET RXI=$PIECE(N,U,2)
SET RXR=$PIECE(N,U,3)
SET N=$PIECE(N,U)
+32 ; maybe, in case fileman blows away N
NEW N57
SET N57=N
+33 ; log file detail of the charge
DO LINEITEM
+34 ; note RXI, RXR on the VCPT
DO MARKVCPT
+35 ; record in .57 file that this entry has been billed
DO UPDATE57
+36 ; 9002313.02 claim points to PCN
DO UPDATE02
+37 IF $$GET1^DIQ(9002313.57,N57_",","RESULT WITH REVERSAL")?1"E ".E
Begin DoDot:2
+38 ; electronic claim? do not print form.
DO OFFNCPDP^ABSBPBRX(PCNDFN)
End DoDot:2
End DoDot:1
+39 QUIT PCNDFN
COMBINS ; have to update the combined insurance file? Yes.
+1 ; because DO ^ABSBMAKE refers back to combined insurance.
+2 ; (This is new. Sitka didn't need it because back then,
+3 ; ILC and Point of Sale used the same ^ABSBCOMB.)
+4 NEW PATDFN
SET PATDFN=$PIECE(^AUPNVSIT(VSTDFN,0),U,5)
+5 ; FSI/ILC A/R Version 2
IF $DATA(^ABSBCOMB)
Begin DoDot:1
+6 DO EN^VTLCOMB(PATDFN)
End DoDot:1
+7 ; FSI/ILC A/R Version 1
IF '$TEST
Begin DoDot:1
+8 NEW D1,ELGBEG,ELGEND,GRPDFN,GRPNAM,GRPNUM,INSDFN,INSNAM
+9 NEW POLDFN,POLNAM,POLNUM,POLREC,REC,REL,X
+10 DO ^ABSBCOMB(PATDFN)
End DoDot:1
+11 QUIT
LINEITEM ;
+1 NEW DRGDFN,NDC,DRGNAME,CHARGE,X,QTY
+2 SET DRGDFN=$PIECE(^PSRX(RXI,0),U,6)
+3 ; fixed 03/26/2001
SET NDC=$PIECE(^ABSPTL(N57,1),U,2)
+4 SET DRGNAME=$PIECE($GET(^PSDRUG(DRGDFN,0)),U)
+5 SET CHARGE=$PIECE(^ABSVCPT(9002301,VCPT,0),U,5)
+6 SET QTY=$PIECE(^ABSPTL(N57,5),U)
+7 IF QTY#1
SET QTY=$JUSTIFY(QTY,8,3)
+8 IF '$TEST
SET QTY=$JUSTIFY(QTY,4)
+9 SET X=QTY_" "_$$ANFF^ABSPECFM(DRGNAME,25)_" "
+10 SET X=X_$$ANFF^ABSPECFM($$FORMTNDC^ABSPOS9(NDC),13)
+11 SET X=X_" "_$JUSTIFY(CHARGE,8,2)
+12 SET X=X_" ("_VCPT_")"
+13 DO LOG^ABSPOSL(X)
+14 QUIT
MARKVCPT ;
+1 NEW DIE,DA,DR,DIDEL,DTOUT
+2 SET DIE=9002301
SET DA=VCPT
SET DR="56////"_RXI_";56.3////"_RXR_";56.4////"_N57
+3 DO ^DIE
+4 QUIT
UPDATE57 ; record in POS data that this VCPT has been billed
+1 NEW DIE,DA,DR,DIDEL,DTOUT
+2 SET DIE=9002313.57
SET DA=N57
SET DR="2////"_PCNDFN
DO ^DIE
+3 QUIT
+4 QUIT
UPDATE02 ;
+1 NEW DIE,DA,DR,DIDEL,DTOUT
+2 SET DIE=9002313.02
SET DA=$PIECE(^ABSPTL(N57,0),U,4)
+3 IF 'DA
QUIT
+4 SET DR=".03////"_PCNDFN_";1.02///"_PCN_";1.03///"_VCN
+5 DO ^DIE
+6 QUIT
ARTYPNUM ; determine the AR TYPE number for the current VCN
+1 NEW OK,PHARM
ART2 SET OK=1
+1 DO FIRSTN
+2 ; point to .56
SET PHARM=$PIECE(^ABSPTL(N,1),U,7)
+3 SET ARTYPNUM=$PIECE(^ABSP(9002313.56,PHARM,0),U,4)
+4 IF 'ARTYPNUM
SET ARTYPNUM=$PIECE(^ABSP(9002313.99,1,"RX A/R TYPE"),U)
+5 IF 'ARTYPNUM
SET OK=0
+6 ; be overly cautious about this
IF OK
IF '$DATA(^ABSBTYP(ARTYPNUM))
SET OK=0
+7 IF 'OK
IF $$IMPOSS^ABSPOSUE("DB","RTI","A/R TYPE missing from setup file",,"ARTYPNUM",$TEXT(+0))
GOTO ART2
+8 QUIT
PINS ; set PINS = the right PINS node for this VCN
+1 DO FIRSTN
+2 SET PINS=^ABSPTL(N,6)
+3 QUIT
FIRSTN ; S N=first 9002313.57 for the first VCPT for this VCN
+1 ; used by ARTYPNUM and PINS
+2 NEW VCPT
SET VCPT=$ORDER(^BLL($JOB,VCN,0))
+3 ; get first VCPT
IF 'VCPT
Begin DoDot:1
+4 DO IMPOSS^ABSPOSUE("P","TI","Incomplete ^BLL array",,"FIRSTN",$TEXT(+0))
End DoDot:1
QUIT
+5 ; point to the 9002313.57 record
SET N=$PIECE(^TMP($JOB,"VCPT",VCPT),U)
+6 QUIT
NULLOPEN() ; open null file, because ^ABSBMAKE echoes to screen
+1 SET X=$$GET1^DIQ(9002313.99,"1,",1490)
+2 NEW DIR,FILE,SLASH,SLASHCH
+3 SET SLASH=$SELECT(X["/":"/",X["\":"\",1:"")
+4 IF SLASH]""
Begin DoDot:1
+5 NEW N
SET N=$LENGTH(X,SLASH)
+6 SET DIR=$PIECE(X,SLASH,1,N-1)_SLASH
+7 SET FILE=$PIECE(X,SLASH,N)
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 IF X=""
SET DIR=""
SET FILE=$TEXT(+0)_".tmp"
+10 IF '$TEST
SET DIR=""
SET FILE=X
End DoDot:1
+11 DO OPEN^%ZISH($$NULLHNDL,DIR,FILE,"W")
+12 ; 1 success, 0 failure
QUIT '$GET(POP)
NULLCLOS DO CLOSE^%ZISH($$NULLHNDL)
QUIT
NULLHNDL() QUIT 54
