- FBUCUTL ;ALBISC/TET - UNAUTHORIZED CLAIMS UTILITY ;12/7/2001
- ;;3.5;FEE BASIS;**38**;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- CDTC(X1,X2) ;date comparison
- ;INPUT: X1 = date
- ; X2 = days to subtract or add
- ;OUTPUT: date less/plus x days
- N X D C^%DTC K %H Q $G(X)
- ;
- DTC(X1,X2) ;days between two days
- ;INPUT: X1 = date one
- ; X2 = date two
- ;OUTPUT: difference between two days
- N X,%Y D ^%DTC K %Y Q $G(X)
- ;
- VET(X) ;veteran name
- ;INPUT: internal entry number of veteran
- ;OUTPUT: veteran name or unknown
- S X=$G(^DPT(+X,0)) Q $S($P(X,U)]"":$P(X,U),1:"UNKNOWN")
- ;
- VEN(X) ;vendor name
- ;INPUT: internal entry number of vendor
- ;OUTPUT: vendor name or unknown
- S X=$G(^FBAAV(+X,0)) Q $S($P(X,U)]"":$P(X,U),1:"UNKNOWN")
- ;
- PROG(X) ;fee program name
- ;INPUT: internal entry number of fee program
- ;OUTPUT: fee program name or unknown
- S X=$G(^FBAA(161.8,+X,0)) Q $S($P(X,U)]"":$P(X,U),1:"UNKNOWN")
- ;
- PTR(FBGL,FBIEN) ;get .01 value of pointer
- ;INPUT: FBGL = global root
- ; FBIEN = internal entry number (DA) of pointed to file
- ;OUTPUT: zero node, or 'UNKNOWN'
- N FBVAL,NODE S NODE=FBGL_+FBIEN_",0)"
- S FBVAL=$G(@(NODE))
- Q $S(FBVAL]"":FBVAL,1:"UNKNOWN")
- ;
- LOCK(FBGL,FBDA,GO) ;lock entry before editing
- ;INPUT: FBGL = global root
- ; FBDA = interal entry number of file
- ; GO = 1 to continue to try (enter/updates),
- ; 0 to notify user and quit on failure (edits)
- ; (optional, if not set will be set to 0)
- ;OUTPUT: FBLOCK = 1 if successful; 0 if failed
- ; incremental lock may be issued
- S FBLOCK=0,GO=$S('$D(GO):0,1:+GO) I $S('$D(FBGL):1,FBGL']"":1,'$D(FBDA):1,'+FBDA:1,1:0) Q
- S FBGL=FBGL_FBDA_")"
- L L +@FBGL:2 S FBLOCK=$T I 'FBLOCK G:GO L W:'GO&('$D(ZTQUEUED)) !,"Another user is editing this entry."
- Q
- DAYS(X,FB1725) ;number of days associated with a status
- ;INPUT: X=ien of status in file 162.92
- ; FB1725=true if days for 38 U.S.C. 1725 claim should be returned
- ;OUTPUT: 0 or number of days
- N FBY
- S FBY=$G(^FB(162.92,X,0))
- Q $S($G(FB1725):+$P(FBY,U,7),1:+$P(FBY,U,3))
- ;
- DISAP(DA1,X) ;disapproval reason for disapproved dispositions
- ;INPUT: DA1 = DA of top level of record (DA(1))
- ; X = ien of disapproval reason, 162.94
- ;OUTPUT: none - entry to disapproval multiple if not already there, disapproval reason is active and disposition reason is other than approved.
- N Y,DA,DIC
- S DIC(0)="Z",DIC="^FB583("_DA1_",""D"","
- I $P(^FB583(DA1,0),U,11)>1,$P(^FB(162.94,+X,0),U,2),'$D(^FB583(DA1,"D","B",+X)) S:'$D(^FB583(DA1,"D")) ^FB583(DA1,"D",0)="^162.715PA^^" S DA(1)=DA1 K DD,DO D FILE^DICN
- Q
- STATUS(X) ;get status internal entry number
- ;INPUT: X = order number of status in file 162.92
- ;OUTPUT: ien of status in file 162.92 (status file)
- Q +$O(^FB(162.92,"AO",X,0))
- ;
- ORDER(X) ;get order number of status
- ;INPUT: X = ien of status in file 162.92, status file
- ;OUTPUT: order number of status
- S X=$G(^FB(162.92,+X,0)) Q +$P(X,U,4)
- ;
- PAY(X,FBGL) ;determine if any payments have been made
- ;INPUT: X= ien in file
- ; FBGL= global root
- ;OUTPUT: 0 if no payments, 1 if payments
- S:$E(FBGL,1)="^" FBGL=$P(FBGL,"^",2) S FBGL=X_";"_FBGL
- Q $S(+$O(^FBAA(162.1,"AO",FBGL,0)):1,+$O(^FBAAC("AM",FBGL,0)):1,+$O(^FBAAI("E",FBGL,0)):1,1:0)
- ;
- OVER(KEY) ;determine if ability to override
- ;INPUT: KEY=security key
- ;OUTPUT: 0 if not holder of key, 1 if holder of key
- Q $S($D(^XUSEC(KEY,DUZ)):1,1:0)
- ;
- UPOK(X) ;ok to update
- ;INPUT: X= ien of 162.7
- ;OUTPUT: 0 if NOT OK to update, 1 if OK to update
- Q $S('$$PAY(X,"^FB583("):1,$$OVER("FBAASUPERVISOR"):1,1:0)
- ;
- TIME(ED) ;determine if expiration date passed
- ;INPUT: ED= expiration date
- ;OUTPUT: 0 if late, 1 if within timeframe
- Q $S('ED:1,DT>ED:0,1:1)
- UNTIME(FBX) ;write untimely message - called from input templates
- ;INPUT: FBX = disapproval reason
- W !?5,"Claim has been dispositioned to DISAPPROVED" W:+FBX !?8,"with disapproval reason of '",$P($$PTR("^FB(162.94,",FBX),U),"'.",!,*7
- Q
- ;
- FBZ(X) ;get zero node on 162.7
- ;INPUT: X = ien of 162.7, unauthorized claim file
- ;OUTPUT: zero node of 162.7
- I '+X Q 0
- S X=+X Q $G(^FB583(X,0))
- ;
- FILE(FBGL,X,FBDI,FBDA1) ;add entry to file or subfile
- ;INPUT: FBGL = global root
- ; X = value for .01 field
- ; FBDI = 1 for dinum entry, 0 or null if not (optional)
- ; FBDA1 = DA(1) value (optional), if doesn't exist will not set
- ;OUTPUT: entry is added to designated file
- ; Y is returned ien^value of .01 field^1
- N DA,DIC,DINUM,Y I $S(X']"":1,'$D(FBDI):1,+FBDI&(X'=+X):1,'$D(FBDA):1,1:0) Q ""
- I $D(FBDA1) S DA(1)=FBDA1
- ADD S:+FBDI DINUM=X S DIC(0)="MZ",DIC=FBGL K DD,DO D FILE^DICN G:+Y'>0 ADD K DIC,DINUM
- Q $G(Y)
- ;
- PEND(FBDA) ;check if any info pending for claim
- ;INPUT: FBDA = ien of unauthorized claim in 162.7
- ;OUTPUT: 1 if info pending, otherwise 0
- Q $S(+$O(^FBAA(162.8,"ACD",FBDA,0)):1,1:0)
- PAYST(FBDA,FBUCP) ; unauthorized claim payment status (released+)
- ;INPUT: FBDA = ien of unauthorized claim in 162.7
- ; FBUCP = name of array (optional)
- ;RESULT: 1 (true) if at least one payment and all have been released
- ; 0 (false) if no payments or if some have not been released
- ;OUTPUT: if FBCUP contains the name of an array then that array will
- ; be populated with payment information in the following format
- ; array (claim ien) = result ^ number of payments
- ; array (claim ien, payment file #, payment iens) = batch status
- N FBGL,FBRET,FBPDA,FBPDA1,FBPDA2,FBPDA3,FBBS,FBC
- S FBRET=1
- S FBC=0
- I $G(FBUCP)]"" K FBCUP(FBDA)
- S FBGL=FBDA_";FB583("
- ; pharmacy payments
- S FBPDA=0
- F S FBPDA=$O(^FBAA(162.1,"AO",FBGL,FBPDA)) Q:'FBPDA D
- .S FBPDA1=0
- .F S FBPDA1=$O(^FBAA(162.1,"AO",FBGL,FBPDA,FBPDA1)) Q:'FBPDA1 D
- ..S FBIENS=FBPDA1_","_FBPDA_","
- ..S FBBS=$$GET1^DIQ(162.11,FBIENS,"13:11","I")
- ..I $G(FBUCP)]"" S @FBUCP@(FBDA,162.11,FBIENS)=FBBS
- ..I "^S^T^V^R^"'[(U_FBBS_U) S FBRET=0
- ..S FBC=FBC+1
- ; outpatient and ancillary payments
- S FBPDA=0
- F S FBPDA=$O(^FBAAC("AM",FBGL,FBPDA)) Q:'FBPDA D
- .S FBPDA1=0
- .F S FBPDA1=$O(^FBAAC("AM",FBGL,FBPDA,FBPDA1)) Q:'FBPDA1 D
- ..S FBPDA2=0
- ..F S FBPDA2=$O(^FBAAC("AM",FBGL,FBPDA,FBPDA1,FBPDA2)) Q:'FBPDA2 D
- ...S FBPDA3=0
- ...F S FBPDA3=$O(^FBAAC("AM",FBGL,FBPDA,FBPDA1,FBPDA2,FBPDA3)) Q:'FBPDA3 D
- ....S FBIENS=FBPDA3_","_FBPDA2_","_FBPDA1_","_FBPDA_","
- ....S FBBS=$$GET1^DIQ(162.03,FBIENS,"7:11","I")
- ....I $G(FBUCP)]"" S @FBUCP@(FBDA,162.03,FBIENS)=FBBS
- ....I "^S^T^V^R^"'[(U_FBBS_U) S FBRET=0
- ....S FBC=FBC+1
- ; civil hospital payments
- S FBPDA=0
- F S FBPDA=$O(^FBAAI("E",FBGL,FBPDA)) Q:'FBPDA D
- .S FBIENS=FBPDA_","
- .S FBBS=$$GET1^DIQ(162.5,FBIENS,"20:11","I")
- .I $G(FBUCP)]"" S @FBUCP@(FBDA,162.5,FBIENS)=FBBS
- .I "^S^T^V^R^"'[(U_FBBS_U) S FBRET=0
- .S FBC=FBC+1
- I FBC=0 S FBRET=0
- I $G(FBUCP)]"" S @FBUCP@(FBDA)=FBRET_U_FBC
- Q FBRET
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUCUTL 7026 printed Jan 18, 2025@03:01:42 Page 2
- FBUCUTL ;ALBISC/TET - UNAUTHORIZED CLAIMS UTILITY ;12/7/2001
- +1 ;;3.5;FEE BASIS;**38**;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- CDTC(X1,X2) ;date comparison
- +1 ;INPUT: X1 = date
- +2 ; X2 = days to subtract or add
- +3 ;OUTPUT: date less/plus x days
- +4 NEW X
- DO C^%DTC
- KILL %H
- QUIT $GET(X)
- +5 ;
- DTC(X1,X2) ;days between two days
- +1 ;INPUT: X1 = date one
- +2 ; X2 = date two
- +3 ;OUTPUT: difference between two days
- +4 NEW X,%Y
- DO ^%DTC
- KILL %Y
- QUIT $GET(X)
- +5 ;
- VET(X) ;veteran name
- +1 ;INPUT: internal entry number of veteran
- +2 ;OUTPUT: veteran name or unknown
- +3 SET X=$GET(^DPT(+X,0))
- QUIT $SELECT($PIECE(X,U)]"":$PIECE(X,U),1:"UNKNOWN")
- +4 ;
- VEN(X) ;vendor name
- +1 ;INPUT: internal entry number of vendor
- +2 ;OUTPUT: vendor name or unknown
- +3 SET X=$GET(^FBAAV(+X,0))
- QUIT $SELECT($PIECE(X,U)]"":$PIECE(X,U),1:"UNKNOWN")
- +4 ;
- PROG(X) ;fee program name
- +1 ;INPUT: internal entry number of fee program
- +2 ;OUTPUT: fee program name or unknown
- +3 SET X=$GET(^FBAA(161.8,+X,0))
- QUIT $SELECT($PIECE(X,U)]"":$PIECE(X,U),1:"UNKNOWN")
- +4 ;
- PTR(FBGL,FBIEN) ;get .01 value of pointer
- +1 ;INPUT: FBGL = global root
- +2 ; FBIEN = internal entry number (DA) of pointed to file
- +3 ;OUTPUT: zero node, or 'UNKNOWN'
- +4 NEW FBVAL,NODE
- SET NODE=FBGL_+FBIEN_",0)"
- +5 SET FBVAL=$GET(@(NODE))
- +6 QUIT $SELECT(FBVAL]"":FBVAL,1:"UNKNOWN")
- +7 ;
- LOCK(FBGL,FBDA,GO) ;lock entry before editing
- +1 ;INPUT: FBGL = global root
- +2 ; FBDA = interal entry number of file
- +3 ; GO = 1 to continue to try (enter/updates),
- +4 ; 0 to notify user and quit on failure (edits)
- +5 ; (optional, if not set will be set to 0)
- +6 ;OUTPUT: FBLOCK = 1 if successful; 0 if failed
- +7 ; incremental lock may be issued
- +8 SET FBLOCK=0
- SET GO=$SELECT('$DATA(GO):0,1:+GO)
- IF $SELECT('$DATA(FBGL):1,FBGL']"":1,'$DATA(FBDA):1,'+FBDA:1,1:0)
- QUIT
- +9 SET FBGL=FBGL_FBDA_")"
- L LOCK +@FBGL:2
- SET FBLOCK=$TEST
- IF 'FBLOCK
- if GO
- GOTO L
- if 'GO&('$DATA(ZTQUEUED))
- WRITE !,"Another user is editing this entry."
- +1 QUIT
- DAYS(X,FB1725) ;number of days associated with a status
- +1 ;INPUT: X=ien of status in file 162.92
- +2 ; FB1725=true if days for 38 U.S.C. 1725 claim should be returned
- +3 ;OUTPUT: 0 or number of days
- +4 NEW FBY
- +5 SET FBY=$GET(^FB(162.92,X,0))
- +6 QUIT $SELECT($GET(FB1725):+$PIECE(FBY,U,7),1:+$PIECE(FBY,U,3))
- +7 ;
- DISAP(DA1,X) ;disapproval reason for disapproved dispositions
- +1 ;INPUT: DA1 = DA of top level of record (DA(1))
- +2 ; X = ien of disapproval reason, 162.94
- +3 ;OUTPUT: none - entry to disapproval multiple if not already there, disapproval reason is active and disposition reason is other than approved.
- +4 NEW Y,DA,DIC
- +5 SET DIC(0)="Z"
- SET DIC="^FB583("_DA1_",""D"","
- +6 IF $PIECE(^FB583(DA1,0),U,11)>1
- IF $PIECE(^FB(162.94,+X,0),U,2)
- IF '$DATA(^FB583(DA1,"D","B",+X))
- if '$DATA(^FB583(DA1,"D"))
- SET ^FB583(DA1,"D",0)="^162.715PA^^"
- SET DA(1)=DA1
- KILL DD,DO
- DO FILE^DICN
- +7 QUIT
- STATUS(X) ;get status internal entry number
- +1 ;INPUT: X = order number of status in file 162.92
- +2 ;OUTPUT: ien of status in file 162.92 (status file)
- +3 QUIT +$ORDER(^FB(162.92,"AO",X,0))
- +4 ;
- ORDER(X) ;get order number of status
- +1 ;INPUT: X = ien of status in file 162.92, status file
- +2 ;OUTPUT: order number of status
- +3 SET X=$GET(^FB(162.92,+X,0))
- QUIT +$PIECE(X,U,4)
- +4 ;
- PAY(X,FBGL) ;determine if any payments have been made
- +1 ;INPUT: X= ien in file
- +2 ; FBGL= global root
- +3 ;OUTPUT: 0 if no payments, 1 if payments
- +4 if $EXTRACT(FBGL,1)="^"
- SET FBGL=$PIECE(FBGL,"^",2)
- SET FBGL=X_";"_FBGL
- +5 QUIT $SELECT(+$ORDER(^FBAA(162.1,"AO",FBGL,0)):1,+$ORDER(^FBAAC("AM",FBGL,0)):1,+$ORDER(^FBAAI("E",FBGL,0)):1,1:0)
- +6 ;
- OVER(KEY) ;determine if ability to override
- +1 ;INPUT: KEY=security key
- +2 ;OUTPUT: 0 if not holder of key, 1 if holder of key
- +3 QUIT $SELECT($DATA(^XUSEC(KEY,DUZ)):1,1:0)
- +4 ;
- UPOK(X) ;ok to update
- +1 ;INPUT: X= ien of 162.7
- +2 ;OUTPUT: 0 if NOT OK to update, 1 if OK to update
- +3 QUIT $SELECT('$$PAY(X,"^FB583("):1,$$OVER("FBAASUPERVISOR"):1,1:0)
- +4 ;
- TIME(ED) ;determine if expiration date passed
- +1 ;INPUT: ED= expiration date
- +2 ;OUTPUT: 0 if late, 1 if within timeframe
- +3 QUIT $SELECT('ED:1,DT>ED:0,1:1)
- UNTIME(FBX) ;write untimely message - called from input templates
- +1 ;INPUT: FBX = disapproval reason
- +2 WRITE !?5,"Claim has been dispositioned to DISAPPROVED"
- if +FBX
- WRITE !?8,"with disapproval reason of '",$PIECE($$PTR("^FB(162.94,",FBX),U),"'.",!,*7
- +3 QUIT
- +4 ;
- FBZ(X) ;get zero node on 162.7
- +1 ;INPUT: X = ien of 162.7, unauthorized claim file
- +2 ;OUTPUT: zero node of 162.7
- +3 IF '+X
- QUIT 0
- +4 SET X=+X
- QUIT $GET(^FB583(X,0))
- +5 ;
- FILE(FBGL,X,FBDI,FBDA1) ;add entry to file or subfile
- +1 ;INPUT: FBGL = global root
- +2 ; X = value for .01 field
- +3 ; FBDI = 1 for dinum entry, 0 or null if not (optional)
- +4 ; FBDA1 = DA(1) value (optional), if doesn't exist will not set
- +5 ;OUTPUT: entry is added to designated file
- +6 ; Y is returned ien^value of .01 field^1
- +7 NEW DA,DIC,DINUM,Y
- IF $SELECT(X']"":1,'$DATA(FBDI):1,+FBDI&(X'=+X):1,'$DATA(FBDA):1,1:0)
- QUIT ""
- +8 IF $DATA(FBDA1)
- SET DA(1)=FBDA1
- ADD if +FBDI
- SET DINUM=X
- SET DIC(0)="MZ"
- SET DIC=FBGL
- KILL DD,DO
- DO FILE^DICN
- if +Y'>0
- GOTO ADD
- KILL DIC,DINUM
- +1 QUIT $GET(Y)
- +2 ;
- PEND(FBDA) ;check if any info pending for claim
- +1 ;INPUT: FBDA = ien of unauthorized claim in 162.7
- +2 ;OUTPUT: 1 if info pending, otherwise 0
- +3 QUIT $SELECT(+$ORDER(^FBAA(162.8,"ACD",FBDA,0)):1,1:0)
- PAYST(FBDA,FBUCP) ; unauthorized claim payment status (released+)
- +1 ;INPUT: FBDA = ien of unauthorized claim in 162.7
- +2 ; FBUCP = name of array (optional)
- +3 ;RESULT: 1 (true) if at least one payment and all have been released
- +4 ; 0 (false) if no payments or if some have not been released
- +5 ;OUTPUT: if FBCUP contains the name of an array then that array will
- +6 ; be populated with payment information in the following format
- +7 ; array (claim ien) = result ^ number of payments
- +8 ; array (claim ien, payment file #, payment iens) = batch status
- +9 NEW FBGL,FBRET,FBPDA,FBPDA1,FBPDA2,FBPDA3,FBBS,FBC
- +10 SET FBRET=1
- +11 SET FBC=0
- +12 IF $GET(FBUCP)]""
- KILL FBCUP(FBDA)
- +13 SET FBGL=FBDA_";FB583("
- +14 ; pharmacy payments
- +15 SET FBPDA=0
- +16 FOR
- SET FBPDA=$ORDER(^FBAA(162.1,"AO",FBGL,FBPDA))
- if 'FBPDA
- QUIT
- Begin DoDot:1
- +17 SET FBPDA1=0
- +18 FOR
- SET FBPDA1=$ORDER(^FBAA(162.1,"AO",FBGL,FBPDA,FBPDA1))
- if 'FBPDA1
- QUIT
- Begin DoDot:2
- +19 SET FBIENS=FBPDA1_","_FBPDA_","
- +20 SET FBBS=$$GET1^DIQ(162.11,FBIENS,"13:11","I")
- +21 IF $GET(FBUCP)]""
- SET @FBUCP@(FBDA,162.11,FBIENS)=FBBS
- +22 IF "^S^T^V^R^"'[(U_FBBS_U)
- SET FBRET=0
- +23 SET FBC=FBC+1
- End DoDot:2
- End DoDot:1
- +24 ; outpatient and ancillary payments
- +25 SET FBPDA=0
- +26 FOR
- SET FBPDA=$ORDER(^FBAAC("AM",FBGL,FBPDA))
- if 'FBPDA
- QUIT
- Begin DoDot:1
- +27 SET FBPDA1=0
- +28 FOR
- SET FBPDA1=$ORDER(^FBAAC("AM",FBGL,FBPDA,FBPDA1))
- if 'FBPDA1
- QUIT
- Begin DoDot:2
- +29 SET FBPDA2=0
- +30 FOR
- SET FBPDA2=$ORDER(^FBAAC("AM",FBGL,FBPDA,FBPDA1,FBPDA2))
- if 'FBPDA2
- QUIT
- Begin DoDot:3
- +31 SET FBPDA3=0
- +32 FOR
- SET FBPDA3=$ORDER(^FBAAC("AM",FBGL,FBPDA,FBPDA1,FBPDA2,FBPDA3))
- if 'FBPDA3
- QUIT
- Begin DoDot:4
- +33 SET FBIENS=FBPDA3_","_FBPDA2_","_FBPDA1_","_FBPDA_","
- +34 SET FBBS=$$GET1^DIQ(162.03,FBIENS,"7:11","I")
- +35 IF $GET(FBUCP)]""
- SET @FBUCP@(FBDA,162.03,FBIENS)=FBBS
- +36 IF "^S^T^V^R^"'[(U_FBBS_U)
- SET FBRET=0
- +37 SET FBC=FBC+1
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +38 ; civil hospital payments
- +39 SET FBPDA=0
- +40 FOR
- SET FBPDA=$ORDER(^FBAAI("E",FBGL,FBPDA))
- if 'FBPDA
- QUIT
- Begin DoDot:1
- +41 SET FBIENS=FBPDA_","
- +42 SET FBBS=$$GET1^DIQ(162.5,FBIENS,"20:11","I")
- +43 IF $GET(FBUCP)]""
- SET @FBUCP@(FBDA,162.5,FBIENS)=FBBS
- +44 IF "^S^T^V^R^"'[(U_FBBS_U)
- SET FBRET=0
- +45 SET FBC=FBC+1
- End DoDot:1
- +46 IF FBC=0
- SET FBRET=0
- +47 IF $GET(FBUCP)]""
- SET @FBUCP@(FBDA)=FBRET_U_FBC
- +48 QUIT FBRET