IBBACDM ;OAK/ELZ - PFSS SERVICE MASTER API ;15-MAR-2005
;;2.0;INTEGRATED BILLING;**286**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
GETCODE(IBBCPT,IBBCPTDT) ;return service code based on cpt/hcpcs and date of service
;
;input IBBCPT = pointer to file #81
; IBBCPTDT = service date
;output IBBBSRVC = ien in file #374
; RETURN = service_code^activation_date^inactivation_date
N IBBSRVC,ACTDT,INACTDT,IEN,SUBIEN,NEXTSUB,RETURN,X,XX,XD
S IBBSRVC=999999
Q:'$G(IBBCPT) IBBSRVC_"^^"
Q:'$G(IBBCPTDT) IBBSRVC_"^^"
S ACTDT="",INACTDT="",IEN="",SUBIEN=""
S XD=9999999 F S XD=$O(^IBBAS(374,"AA",IBBCPT,XD),-1) Q:'XD D Q:$G(ACTDT)
.Q:(XD>IBBCPTDT)
.S ACTDT=XD
.S IEN=$O(^IBBAS(374,"AA",IBBCPT,ACTDT,0)),SUBIEN=$O(^IBBAS(374,"AA",IBBCPT,ACTDT,IEN,0))
.S NEXTSUB=$O(^IBBAS(374,IEN,1,SUBIEN)) I 'NEXTSUB Q
.S INACTDT=$P(^IBBAS(374,IEN,1,NEXTSUB,0),"^",2)
.I INACTDT'>IBBCPTDT S IEN=""
I IEN S IBBSRVC=IEN,RETURN=IBBSRVC_"^"_ACTDT_"^"_INACTDT
E S RETURN=IBBSRVC_"^^"
Q RETURN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBBACDM 1064 printed Oct 16, 2024@18:09 Page 2
IBBACDM ;OAK/ELZ - PFSS SERVICE MASTER API ;15-MAR-2005
+1 ;;2.0;INTEGRATED BILLING;**286**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
GETCODE(IBBCPT,IBBCPTDT) ;return service code based on cpt/hcpcs and date of service
+1 ;
+2 ;input IBBCPT = pointer to file #81
+3 ; IBBCPTDT = service date
+4 ;output IBBBSRVC = ien in file #374
+5 ; RETURN = service_code^activation_date^inactivation_date
+6 NEW IBBSRVC,ACTDT,INACTDT,IEN,SUBIEN,NEXTSUB,RETURN,X,XX,XD
+7 SET IBBSRVC=999999
+8 if '$GET(IBBCPT)
QUIT IBBSRVC_"^^"
+9 if '$GET(IBBCPTDT)
QUIT IBBSRVC_"^^"
+10 SET ACTDT=""
SET INACTDT=""
SET IEN=""
SET SUBIEN=""
+11 SET XD=9999999
FOR
SET XD=$ORDER(^IBBAS(374,"AA",IBBCPT,XD),-1)
if 'XD
QUIT
Begin DoDot:1
+12 if (XD>IBBCPTDT)
QUIT
+13 SET ACTDT=XD
+14 SET IEN=$ORDER(^IBBAS(374,"AA",IBBCPT,ACTDT,0))
SET SUBIEN=$ORDER(^IBBAS(374,"AA",IBBCPT,ACTDT,IEN,0))
+15 SET NEXTSUB=$ORDER(^IBBAS(374,IEN,1,SUBIEN))
IF 'NEXTSUB
QUIT
+16 SET INACTDT=$PIECE(^IBBAS(374,IEN,1,NEXTSUB,0),"^",2)
+17 IF INACTDT'>IBBCPTDT
SET IEN=""
End DoDot:1
if $GET(ACTDT)
QUIT
+18 IF IEN
SET IBBSRVC=IEN
SET RETURN=IBBSRVC_"^"_ACTDT_"^"_INACTDT
+19 IF '$TEST
SET RETURN=IBBSRVC_"^^"
+20 QUIT RETURN
+21 ;
