source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTUTL4.m@ 1325

Last change on this file since 1325 was 613, checked in by George Lilly, 16 years ago

initial load of WorldVistAEHR
File size: 5.4 KB
Line 
1IBTUTL4 ;ALB/AAS - CLAIMS TRACKING UTILITY ROUTINE ; 21-JUN-93
2 ;;2.0;INTEGRATED BILLING;**60,91**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5AEA(IBTRC,X) ; -- dd input call for authorize entire admission (field 1.08)
6 N ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N S IBOK=1
7 I X,$P($G(^IBT(356.2,+IBTRC,1)),"^",7) D NOTOK("Deny Entire Admission already answered 'YES'.") G AEAQ
8 D ARRAY^IBTUTL3(IBTRC)
9 I $G(ARRAY(0)) D NOTOK("Entired Admission already denied on "_$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY(0),0))))
10 I $G(ARRAY),ARRAY'=IBTRC D NOTOK("Entire Admission has already be authorized on "_$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY,0))))
11AEAQ Q IBOK
12 ;
13DEA(IBTRC,X) ; -- dd input call for deny entry admission (field 1.07)
14 N ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N S IBOK=1
15 I X,$P($G(^IBT(356.2,+IBTRC,1)),"^",8) D NOTOK("Authorize Entire Admission already answered 'YES'.") G DEAQ
16 D ARRAY^IBTUTL3(IBTRC)
17 I $G(ARRAY(0)),+ARRAY(0)'=IBTRC D NOTOK("Entired Admission already denied on "_$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY(0),0))))
18 I $G(ARRAY) D NOTOK("Entire Admission has already be authorized on "_$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY,0))))
19DEAQ Q IBOK
20 ;
21AFDT(IBTRC,X) ; -- dd input call for check to approved from date (field .12)
22 ; -- returns 1 if date okay, 0 if not, let input transform kill x
23 N ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N S IBOK=1
24 ;
25 D CHK I 'IBOK G AFDTQ
26 ;
27 I $P(^IBT(356.2,+IBTRC,0),U,13),X>$P(^(0),"^",13) D NOTOK("Care Authorized From Date must be before the Care Authorized To Date ("_$$FMTE^XLFDT($P(^IBT(356.2,+IBTRC,0),"^",13))_")!") G AFDTQ
28 ;
29 D CHK2 I '$D(ARRAY) G AFDTQ
30 S M=0 F S M=$O(ARRAY(M)) Q:'M S N=0 F S N=$O(ARRAY(M,N)) Q:'N I IBTRC'=+ARRAY(M,N),X'<M,X'>N D NOTOK("Date entered is already covered by another entry.")
31AFDTQ Q IBOK
32 ;
33ATDT(IBTRC,X) ; -- dd input call for check to approved to date (field .13)
34 ; -- returns 1 if date okay, 0 if not, let input transform kill x
35 N ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N S IBOK=1
36 D CHK G:'IBOK ATDTQ
37 ;
38 I $P(^IBT(356.2,+IBTRC,0),U,12),X<$P(^(0),"^",12) D NOTOK("Care Authorized To Date must not be before the Care Authorized From Date ("_$$FMTE^XLFDT($P(^IBT(356.2,+IBTRC,0),"^",13))_")!") G ATDTQ
39 ;
40 D CHK2 I '$D(ARRAY) G ATDTQ
41 S M=0 F S M=$O(ARRAY(M)) Q:'M S N=0 F S N=$O(ARRAY(M,N)) Q:'N I IBTRC'=+ARRAY(M,N),X'<M,X'>N D NOTOK("Date entered is already covered by another entry.")
42ATDTQ Q IBOK
43 ;
44DFDT(IBTRC,X) ; -- dd input call for check to denied from date (field .15)
45 ; -- returns 1 if date okay, 0 if not, let input transform kill x
46 N ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N S IBOK=1
47 D CHK G:'IBOK DFDTQ
48 ;
49 I $P(^IBT(356.2,+IBTRC,0),U,16),X>$P(^(0),"^",16) D NOTOK("Care Denied From Date must be before the Care Denied To Date ("_$$FMTE^XLFDT($P(^IBT(356.2,+IBTRC,0),"^",13))_")!") G DFDTQ
50 ;
51 D CHK2 I '$D(ARRAY) G DFDTQ
52 S M=0 F S M=$O(ARRAY(M)) Q:'M S N=0 F S N=$O(ARRAY(M,N)) Q:'N I IBTRC'=+ARRAY(M,N),X'<M,X'>N D NOTOK("Date entered is already covered by another entry.")
53DFDTQ Q IBOK
54 ;
55DTDT(IBTRC,X) ; -- dd input call for check to denied to date (field .16)
56 ; -- returns 1 if date okay, 0 if not, let input transform kill x
57 N ARRAY,IBOK,IBTRN,IBTRND,Y,I,J,M,N S IBOK=1
58 D CHK G:'IBOK DTDTQ
59 ;
60 I $P(^IBT(356.2,+IBTRC,0),U,15),X<$P(^(0),"^",15) D NOTOK("Date must not be before the Care Denied From Date ("_$$FMTE^XLFDT($P(^IBT(356.2,+IBTRC,0),"^",13))_")!") G DTDTQ
61 ;
62 D CHK2 I '$D(ARRAY) G DTDTQ
63 S M=0 F S M=$O(ARRAY(M)) Q:'M S N=0 F S N=$O(ARRAY(M,N)) Q:'N I IBTRC'=+ARRAY(M,N),X'<M,X'>N D NOTOK("Date entered is already covered by another entry.")
64DTDTQ Q IBOK
65 ;
66CHK ; -- generic check functions
67 I '$G(X)!('$G(IBTRC))!($G(^IBT(356.2,+$G(IBTRC),0))="") S IBOK=0 Q
68 S IBTRND=$G(^IBT(356,+$P($G(^IBT(356.2,+IBTRC,0)),"^",2),0))
69 ;
70 I X<($P(IBTRND,"^",6)\1) D NOTOK("Date can't be before admission or visit date ("_$$FMTE^XLFDT($P(IBTRND,"^",6))_")!") Q
71 ;
72 S Y=$$DISCH(+$P(IBTRND,"^",5)) I Y,X>Y D NOTOK("Date can not be after Discharge Date ("_$$FMTE^XLFDT(Y)_")!") Q
73 Q
74 ;
75CHK2 ; -- if pass first set of check do these
76 D ARRAY^IBTUTL3(IBTRC)
77 I $G(ARRAY) D NOTOK("Whole Admission has already been Authorized, can not add partial dates!")
78 I $G(ARRAY(0)) D NOTOK("Whole Admission has already been Denied, can not add partial dates!")
79 Q
80 ;
81NOTOK(MESS) ; -- process not okays
82 S IBOK=0
83 I '$D(ZTQUEUED),$G(MESS)'="" W !,MESS,!
84 Q
85 ;
86DISCH(DGPM) ; -- find discharge date for an admission
87 ;
88 N X S X=""
89 I '$G(^DGPM(+$G(DGPM),0)) G DISCHQ
90 S X=+$G(^DGPM(+$P($G(^DGPM(DGPM,0)),"^",17),0))
91DISCHQ Q X
92 ;
93 ;
94ASK(IBTRN,IBW) ; Prompt for Provider or Diagnosis from PCE
95 ; Input: IBTRN -- Pointer to Claims Tracking entry in #356
96 ; IBW -- 1 - Provider | 2 - Diagnosis
97 ;
98 N DFN,IBVSIT,IBTRND,IBPKG,IBOEDATA,IBRESULT,IBCLIN,IBERROR
99 S IBERROR=""
100 I '$G(IBTRN) S IBERROR="No Claims Tracking entry has been provided!" G ASKQ
101 I "^1^2^"'[("^"_$G(IBW)_"^") S IBERROR="The prompt type was not specified!" G ASKQ
102 ;
103 S IBPKG=$O(^DIC(9.4,"C","IB",0))
104 I 'IBPKG S IBERROR="Cannot determine the Package file entry for IB!" G ASKQ
105 ;
106 S IBTRND=$G(^IBT(356,IBTRN,0)),IBOEDATA=$$SCE^IBSDU(+$P(IBTRND,"^",4))
107 S IBVSIT=$P(IBTRND,"^",3),IBCLIN=$P(IBOEDATA,"^",4),DFN=$P(IBTRND,"^",2)
108 I 'IBVSIT S IBVSIT=$P(IBOEDATA,"^",5)
109 I 'IBVSIT S IBERROR="Cannot determine the Visit file entry!" G ASKQ
110 I 'IBCLIN S IBERROR="Cannot determine the Clinic location of the visit!" G ASKQ
111 ;
112 S IBRESULT=$$INTV^PXAPI($S(IBW=1:"PRV",1:"POV"),IBPKG,"IB DATA",IBVSIT,IBCLIN,DFN)
113 ;
114ASKQ I IBERROR]"" W !!,IBERROR,! S DIR(0)="E" D ^DIR K DIR
115 Q
Note: See TracBrowser for help on using the repository browser.