PRCPUPAT.m

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 ---PRCPUPAT   2593     printed  Mar 13, 2025@21:21:04                                                                                                                                                                                                    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)