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

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

initial load of WorldVistAEHR
File size: 3.2 KB
Line 
1IB20P389 ;ALB/ARH - IB*2.0*389 POST INIT: PROSTHETICS ITEM REPLACEMENT ; 20-FEB-2008
2 ;;2.0;INTEGRATED BILLING;**389**;21-MAR-94;Build 6
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 Q
6 ;
7PRE ; Clean up DD, remove fields exported so installs clean
8 ; TRANSFER PRICING INPT PROSTHETIC ITEMS (#351.67), ITEM (.01) Output Transform not deleted by install
9 S DIK="^DD(351.61,",DA(1)=351.61,DA=4.04 D ^DIK K DIK,DA
10 S DIK="^DD(351.67,",DA(1)=351.67,DA=.01 D ^DIK K DIK,DA
11 S DIK="^DD(362.5,",DA(1)=362.5,DA=.03 D ^DIK K DIK,DA
12 Q
13 ;
14 ;
15 ; Add Prosthetics Item Name to IB BILL/CLAIMS PROSTHETICS (#362.5, .05)
16 ; This free text Item Name (#362.5, .05) replaces the ITEM pointer (#362.5, .03) to PROS ITEM MASTER (#661)
17 ; The free Text Item Name will be based on the RECORD (#352.5, .04) if defined, otherwise ITEM (#362.5, .03):
18 ; - Prosthetics HISTORICAL ITEM (660,89) if patient item (#362.5, .04) defined/set
19 ; - Item Master PRE_NIF SHORT DESCRIPTION (#441,52) if defined and Delivery Date before last edit date
20 ; - Item Master SHORT DESCRIPTION (#441,.05) if Delivery Date is after last edit date
21 ;
22 ; Delete all entries in TRANSFER PRICING INPT PROSTHETIC ITEMS (#351.67) file
23 ; List of Prosthetics Item to not bill, changed Item pointer from #661 to #661.1
24 ;
25POST ;
26 N IBA
27 S IBA(1)="",IBA(2)=" IB*2*389 Prosthetics Item Replacement Post-Install .....",IBA(3)="" D MESG K IBA
28 ;
29 D PIDEL ; delete all TP Inpt Prosthetics Item (#352.67)
30 D RBILL ; add prosthetic item name to bill record (#362.5)
31 ;
32 S IBA(1)="",IBA(2)=" IB*2*389 Prosthetics Item Replacement Post-Install Complete",IBA(3)="" D MESG K IBA
33 ;
34 Q
35 ;
36PIDEL ; Delete all entries from TRANSFER PRICING INPT PROSTHETIC ITEMS (#361.67)
37 N IBPIFN,IBCNT,DIK,DIC,DIE,DA,X,Y S IBCNT=0
38 ;
39 S IBPIFN=0 F S IBPIFN=$O(^IBAT(351.67,IBPIFN)) Q:'IBPIFN D
40 . ;
41 . S DA=IBPIFN,DIK="^IBAT(351.67," D ^DIK K DIK,DA S IBCNT=IBCNT+1
42 ;
43 S IBA(1)=" >> "_IBCNT_" TRANSFER PRICING INPT PROSTHETIC ITEMS deleted (#351.67)" D MESG K IBA
44 Q
45 ;
46RBILL ; Replace Bill Prosthetics Item pointer with name (#362.5)
47 N IBPIN,IBPI0,IBDDT,IB661,IB660,IBNAME,IBCNT,DIE,DR,DA,DIC,DA,DO,X,Y S IBCNT=0
48 ;
49 S IBPIN=0 F S IBPIN=$O(^IBA(362.5,IBPIN)) Q:'IBPIN D
50 . S IBPI0=$G(^IBA(362.5,IBPIN,0)) S IBDDT=+IBPI0 Q:$P(IBPI0,U,5)'=""
51 . S IB661=+$P(IBPI0,U,3),IB660=+$P(IBPI0,U,4)
52 . ;
53 . S IBNAME=$$NAME(IB661,IB660,IBDDT) Q:IBNAME=""
54 . ;
55 . S DIE="^IBA(362.5,",DA=IBPIN,DR=".05////^S X=IBNAME" D ^DIE K DIE,DR,DA,DIC,DA,DO S IBCNT=IBCNT+1
56 ;
57 S IBA(1)=" >> "_IBCNT_" IB BILL/CLAIMS PROSTHETICS Records converted (#362.5)" D MESG K IBA
58 Q
59 ;
60NAME(IP661,IP660,IDDT) ; Return free text name description for item
61 N IBNAME,IB441,IBOLD,IBNEW,IBDATE S IDDT=+$G(IDDT),IBNAME=""
62 ;
63 I +$G(IP660) S IBNAME=$P($G(^RMPR(660,IP660,"HST")),U,1)
64 ;
65 I IBNAME="",+$G(IP661) D
66 . S IB441=+$G(^RMPR(661,+IP661,0)) Q:'IB441
67 . S IBOLD=$P($G(^PRC(441,+IB441,9)),U,1) ; pre_nif short description
68 . S IBNEW=$P($G(^PRC(441,+IB441,0)),U,2) ; short description
69 . S IBDATE=$P($G(^PRC(441,+IB441,0)),U,9) ; date item created (last updated)
70 . ;
71 . S IBNAME=IBNEW I IBOLD'="",IDDT<IBDATE S IBNAME=IBOLD
72 ;
73 I $E(IBNAME,1,2)="**" S IBNAME=$P(IBNAME,"**",2)
74 I IBNAME="" S IBNAME="PROSTHETIC ITEM"
75 ;
76 Q IBNAME
77 ;
78MESG ;
79 D MES^XPDUTL(.IBA)
80 Q
Note: See TracBrowser for help on using the repository browser.