source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUPAT.m@ 897

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

initial load of FOIAVistA 6/30/08 version

File size: 2.5 KB
Line 
1PRCPUPAT ;WISC/RFJ-move item from prim to seco to patient ;09 Mar 94
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7PATIENT(PATDFN,SURGDA) ; create patient distribution entry for patdfn
8 ; return entry created
9 N %,%H,%I,DA,X,Y
10 I 'PATDFN Q 0
11 D NOW^%DTC
12 S DA=$$ADD(%,PATDFN)
13 I SURGDA D SURGERY(DA,SURGDA)
14 Q DA
15 ;
16 ;
17SURGERY(DA,SURGDA) ; update distribution with surgery data
18 I '$D(^PRCP(446.1,DA,0)) Q
19 N %,D0,DI,DIC,DIE,DQ,DR,OPCODE,OPROOM,PRCPSDAT,SURGDATA,SURGEON,SURGSPEC,X,Y
20 ; get surgery data
21 D SURGDATA^PRCPCRPL(SURGDA,".01;.011;.02;.04;.14;27")
22 I '$D(PRCPSDAT(130,SURGDA,.01,"I")) Q
23 ;
24 S DR="1///S;2///`"_PRCPSDAT(130,SURGDA,.01,"I")_";"
25 ; operating room
26 S OPROOM=+$G(PRCPSDAT(130,SURGDA,.02,"I")) I OPROOM S DR=DR_"130.02///`"_OPROOM_";"
27 ; surgical specialty
28 S SURGSPEC=$G(PRCPSDAT(130,SURGDA,.04,"I")) I SURGSPEC S DR=DR_"130.03///`"_SURGSPEC_";"
29 ; inpatient/outpatient
30 I $D(PRCPSDAT(130,SURGDA,.011,"E")) S DR=DR_"3///"_PRCPSDAT(130,SURGDA,.011,"E")_";"
31 ; surgeon
32 S SURGEON=$G(PRCPSDAT(130,SURGDA,.14,"I")) I SURGEON S DR=DR_"130.04///`"_SURGEON_";"
33 ; principal procedure code
34 S OPCODE=$G(PRCPSDAT(130,SURGDA,27,"I")) I OPCODE S DR=DR_"130.01///`"_OPCODE_";"
35 ;
36 ; add fields to entry
37 L +^PRCP(446.1,DA)
38 S (DIC,DIE)="^PRCP(446.1," D ^DIE
39 L -^PRCP(446.1,DA)
40 Q
41 ;
42 ;
43ADD(DATETIME,PATDFN) ; add new entry to patient distribution file
44 N %,DA,D0,DD,DI,DIC,DIE,DINUM,DLAYGO,DQ,DR,PRCPPRIV,X,Y
45 L +^PRCP(446.1)
46 S DIC="^PRCP(446.1,",DIC(0)="L",DIC("DR")="2///`"_PATDFN,DLAYGO=446.1,PRCPPRIV=1,(DINUM,X)=DATETIME
47 D FILE^DICN
48 L -^PRCP(446.1)
49 Q +Y
50 ;
51 ;
52DISTITEM(DATETIME,ITEMDA,QTY,COST) ; distribute itemda to patient
53 ; qty and cost distributed
54 I '$D(^PRCP(446.1,DATETIME,0)) Q
55 L +^PRCP(446.1,DATETIME)
56 N DATA
57 I '$D(^PRCP(446.1,DATETIME,445,ITEMDA,0)) D
58 . I '$D(^PRCP(446.1,DATETIME,445,0)) S ^(0)="^446.11P^^"
59 . N D0,DA,DD,DIC,DLAYGO,X,Y
60 . S DIC="^PRCP(446.1,"_DATETIME_",445,",DIC(0)="L",DLAYGO=446.1,DA(1)=DATETIME,(X,DINUM)=ITEMDA D FILE^DICN
61 S DATA=$G(^PRCP(446.1,DATETIME,445,ITEMDA,0)) I DATA="" L -^PRCP(446.1,DATETIME) Q
62 S $P(DATA,"^",2)=$P(DATA,"^",2)+QTY
63 S $P(DATA,"^",3)=$P(DATA,"^",3)+COST
64 S ^PRCP(446.1,DATETIME,445,ITEMDA,0)=DATA
65 S $P(^PRCP(446.1,DATETIME,0),"^",5)=$P(^PRCP(446.1,DATETIME,0),"^",5)+COST
66 L -^PRCP(446.1,DATETIME)
67 Q
68 ;
69 ;
70SELECT() ; return selected entry
71 N %,DIC,PRCPPRIV,X,Y
72 S DIC="^PRCP(446.1,",DIC(0)="QEAM",PRCPPRIV=1
73 D ^DIC
74 Q $S(Y'>0:0,1:+Y)
Note: See TracBrowser for help on using the repository browser.