PRCPUPAT ;WISC/RFJ-move item from prim to seco to patient ;09 Mar 94
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
PATIENT(PATDFN,SURGDA) ; create patient distribution entry for patdfn
; return entry created
N %,%H,%I,DA,X,Y
I 'PATDFN Q 0
D NOW^%DTC
S DA=$$ADD(%,PATDFN)
I SURGDA D SURGERY(DA,SURGDA)
Q DA
;
;
SURGERY(DA,SURGDA) ; update distribution with surgery data
I '$D(^PRCP(446.1,DA,0)) Q
N %,D0,DI,DIC,DIE,DQ,DR,OPCODE,OPROOM,PRCPSDAT,SURGDATA,SURGEON,SURGSPEC,X,Y
; get surgery data
D SURGDATA^PRCPCRPL(SURGDA,".01;.011;.02;.04;.14;27")
I '$D(PRCPSDAT(130,SURGDA,.01,"I")) Q
;
S DR="1///S;2///`"_PRCPSDAT(130,SURGDA,.01,"I")_";"
; operating room
S OPROOM=+$G(PRCPSDAT(130,SURGDA,.02,"I")) I OPROOM S DR=DR_"130.02///`"_OPROOM_";"
; surgical specialty
S SURGSPEC=$G(PRCPSDAT(130,SURGDA,.04,"I")) I SURGSPEC S DR=DR_"130.03///`"_SURGSPEC_";"
; inpatient/outpatient
I $D(PRCPSDAT(130,SURGDA,.011,"E")) S DR=DR_"3///"_PRCPSDAT(130,SURGDA,.011,"E")_";"
; surgeon
S SURGEON=$G(PRCPSDAT(130,SURGDA,.14,"I")) I SURGEON S DR=DR_"130.04///`"_SURGEON_";"
; principal procedure code
S OPCODE=$G(PRCPSDAT(130,SURGDA,27,"I")) I OPCODE S DR=DR_"130.01///`"_OPCODE_";"
;
; add fields to entry
L +^PRCP(446.1,DA)
S (DIC,DIE)="^PRCP(446.1," D ^DIE
L -^PRCP(446.1,DA)
Q
;
;
ADD(DATETIME,PATDFN) ; add new entry to patient distribution file
N %,DA,D0,DD,DI,DIC,DIE,DINUM,DLAYGO,DQ,DR,PRCPPRIV,X,Y
L +^PRCP(446.1)
S DIC="^PRCP(446.1,",DIC(0)="L",DIC("DR")="2///`"_PATDFN,DLAYGO=446.1,PRCPPRIV=1,(DINUM,X)=DATETIME
D FILE^DICN
L -^PRCP(446.1)
Q +Y
;
;
DISTITEM(DATETIME,ITEMDA,QTY,COST) ; distribute itemda to patient
; qty and cost distributed
I '$D(^PRCP(446.1,DATETIME,0)) Q
L +^PRCP(446.1,DATETIME)
N DATA
I '$D(^PRCP(446.1,DATETIME,445,ITEMDA,0)) D
. I '$D(^PRCP(446.1,DATETIME,445,0)) S ^(0)="^446.11P^^"
. N D0,DA,DD,DIC,DLAYGO,X,Y
. S DIC="^PRCP(446.1,"_DATETIME_",445,",DIC(0)="L",DLAYGO=446.1,DA(1)=DATETIME,(X,DINUM)=ITEMDA D FILE^DICN
S DATA=$G(^PRCP(446.1,DATETIME,445,ITEMDA,0)) I DATA="" L -^PRCP(446.1,DATETIME) Q
S $P(DATA,"^",2)=$P(DATA,"^",2)+QTY
S $P(DATA,"^",3)=$P(DATA,"^",3)+COST
S ^PRCP(446.1,DATETIME,445,ITEMDA,0)=DATA
S $P(^PRCP(446.1,DATETIME,0),"^",5)=$P(^PRCP(446.1,DATETIME,0),"^",5)+COST
L -^PRCP(446.1,DATETIME)
Q
;
;
SELECT() ; return selected entry
N %,DIC,PRCPPRIV,X,Y
S DIC="^PRCP(446.1,",DIC(0)="QEAM",PRCPPRIV=1
D ^DIC
Q $S(Y'>0:0,1:+Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUPAT 2593 printed Oct 16, 2024@18:17 Page 2
PRCPUPAT ;WISC/RFJ-move item from prim to seco to patient ;09 Mar 94
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
PATIENT(PATDFN,SURGDA) ; create patient distribution entry for patdfn
+1 ; return entry created
+2 NEW %,%H,%I,DA,X,Y
+3 IF 'PATDFN
QUIT 0
+4 DO NOW^%DTC
+5 SET DA=$$ADD(%,PATDFN)
+6 IF SURGDA
DO SURGERY(DA,SURGDA)
+7 QUIT DA
+8 ;
+9 ;
SURGERY(DA,SURGDA) ; update distribution with surgery data
+1 IF '$DATA(^PRCP(446.1,DA,0))
QUIT
+2 NEW %,D0,DI,DIC,DIE,DQ,DR,OPCODE,OPROOM,PRCPSDAT,SURGDATA,SURGEON,SURGSPEC,X,Y
+3 ; get surgery data
+4 DO SURGDATA^PRCPCRPL(SURGDA,".01;.011;.02;.04;.14;27")
+5 IF '$DATA(PRCPSDAT(130,SURGDA,.01,"I"))
QUIT
+6 ;
+7 SET DR="1///S;2///`"_PRCPSDAT(130,SURGDA,.01,"I")_";"
+8 ; operating room
+9 SET OPROOM=+$GET(PRCPSDAT(130,SURGDA,.02,"I"))
IF OPROOM
SET DR=DR_"130.02///`"_OPROOM_";"
+10 ; surgical specialty
+11 SET SURGSPEC=$GET(PRCPSDAT(130,SURGDA,.04,"I"))
IF SURGSPEC
SET DR=DR_"130.03///`"_SURGSPEC_";"
+12 ; inpatient/outpatient
+13 IF $DATA(PRCPSDAT(130,SURGDA,.011,"E"))
SET DR=DR_"3///"_PRCPSDAT(130,SURGDA,.011,"E")_";"
+14 ; surgeon
+15 SET SURGEON=$GET(PRCPSDAT(130,SURGDA,.14,"I"))
IF SURGEON
SET DR=DR_"130.04///`"_SURGEON_";"
+16 ; principal procedure code
+17 SET OPCODE=$GET(PRCPSDAT(130,SURGDA,27,"I"))
IF OPCODE
SET DR=DR_"130.01///`"_OPCODE_";"
+18 ;
+19 ; add fields to entry
+20 LOCK +^PRCP(446.1,DA)
+21 SET (DIC,DIE)="^PRCP(446.1,"
DO ^DIE
+22 LOCK -^PRCP(446.1,DA)
+23 QUIT
+24 ;
+25 ;
ADD(DATETIME,PATDFN) ; add new entry to patient distribution file
+1 NEW %,DA,D0,DD,DI,DIC,DIE,DINUM,DLAYGO,DQ,DR,PRCPPRIV,X,Y
+2 LOCK +^PRCP(446.1)
+3 SET DIC="^PRCP(446.1,"
SET DIC(0)="L"
SET DIC("DR")="2///`"_PATDFN
SET DLAYGO=446.1
SET PRCPPRIV=1
SET (DINUM,X)=DATETIME
+4 DO FILE^DICN
+5 LOCK -^PRCP(446.1)
+6 QUIT +Y
+7 ;
+8 ;
DISTITEM(DATETIME,ITEMDA,QTY,COST) ; distribute itemda to patient
+1 ; qty and cost distributed
+2 IF '$DATA(^PRCP(446.1,DATETIME,0))
QUIT
+3 LOCK +^PRCP(446.1,DATETIME)
+4 NEW DATA
+5 IF '$DATA(^PRCP(446.1,DATETIME,445,ITEMDA,0))
Begin DoDot:1
+6 IF '$DATA(^PRCP(446.1,DATETIME,445,0))
SET ^(0)="^446.11P^^"
+7 NEW D0,DA,DD,DIC,DLAYGO,X,Y
+8 SET DIC="^PRCP(446.1,"_DATETIME_",445,"
SET DIC(0)="L"
SET DLAYGO=446.1
SET DA(1)=DATETIME
SET (X,DINUM)=ITEMDA
DO FILE^DICN
End DoDot:1
+9 SET DATA=$GET(^PRCP(446.1,DATETIME,445,ITEMDA,0))
IF DATA=""
LOCK -^PRCP(446.1,DATETIME)
QUIT
+10 SET $PIECE(DATA,"^",2)=$PIECE(DATA,"^",2)+QTY
+11 SET $PIECE(DATA,"^",3)=$PIECE(DATA,"^",3)+COST
+12 SET ^PRCP(446.1,DATETIME,445,ITEMDA,0)=DATA
+13 SET $PIECE(^PRCP(446.1,DATETIME,0),"^",5)=$PIECE(^PRCP(446.1,DATETIME,0),"^",5)+COST
+14 LOCK -^PRCP(446.1,DATETIME)
+15 QUIT
+16 ;
+17 ;
SELECT() ; return selected entry
+1 NEW %,DIC,PRCPPRIV,X,Y
+2 SET DIC="^PRCP(446.1,"
SET DIC(0)="QEAM"
SET PRCPPRIV=1
+3 DO ^DIC
+4 QUIT $SELECT(Y'>0:0,1:+Y)
