- 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 Apr 23, 2025@18:22:52 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 ;
