| [613] | 1 | MCARPROC ;WISC/TJK,RCH-STORE PROCEDURES IN MEDICINE PATIENT FILE ;7/30/96 13:48
|
|---|
| 2 | ;;2.3;Medicine;;09/13/1996
|
|---|
| 3 | INIT ;INITIALIZE VARIABLES
|
|---|
| 4 | K XX S MCARCDIE=MCARCDIE_DA_",0)" I $P($G(@MCARCDIE),U,1)="" K MCARCDIE Q
|
|---|
| 5 | S XX=$P(@MCARCDIE,U,1),CD=$P(@MCARCDIE,U,2) I CD="" K MCARCDIE,CD,XX
|
|---|
| 6 | Q
|
|---|
| 7 | CHGDTE ;CHANGE PROCEDURE DATE
|
|---|
| 8 | Q:'$D(MCARCDIE) D INIT G END:'$D(CD) S MCAROLDT=X G OLDAC
|
|---|
| 9 | CHGDTE1 ;SET "AC" CROSS-REFERENCE WITH NEW DATE
|
|---|
| 10 | Q:'$D(MCARCDIE) D INIT G END:'$D(CD) S XX=X G CONT1
|
|---|
| 11 | CHGPAT ;TRANSFER PROCEDURE FROM ONE PATIENT TO ANOTHER
|
|---|
| 12 | Q:'$D(MCARCDIE) D INIT G END:'$D(XX),CONT
|
|---|
| 13 | OLDAC K ^MCAR(690,"AC",CD,9999999.9999-MCAROLDT,$P($P(MCARCDIE,U,2),",",1),DA) Q
|
|---|
| 14 | CONT ;NEW PROCEDURE
|
|---|
| 15 | S CD=X
|
|---|
| 16 | CONT1 ;STORE PROCEDURE IN "AC" CROSS REFERENCE OF MEDICINE PATIENT FILE
|
|---|
| 17 | S ^MCAR(690,"AC",CD,9999999.9999-XX,$P($P(MCARCDIE,U,2),",",1),DA)=""
|
|---|
| 18 | END K MCARCDIE,CD,XX,MCAROLDT
|
|---|
| 19 | Q
|
|---|
| 20 | KILL S CD=X,MCAROLDT=MCARCDIE_DA_",0)",MCAROLDT=$P(@MCAROLDT,U,1) D OLDAC K MCAROLDT,CD Q
|
|---|
| 21 | Q
|
|---|
| 22 | MEDSET ;THIS SECTION SETS MEDICINE CODE AND CROSS-REFERENCE IN DRUG FILE
|
|---|
| 23 | ;X-REF NO LONGER USED
|
|---|
| 24 | Q S $P(^PSDRUG(DA,2),U,3)=$S('$D(^PSDRUG(DA,2)):"M",1:$P(^(2),U,3)_"M")
|
|---|
| 25 | S ^PSDRUG("AIUM",$P(^PSDRUG(DA,0),U,1),DA)="" Q
|
|---|
| 26 | MEDKILL ;THIS SECTION DELETES MEDICINE CODE WHEN MEDICATION DELETED FROM MEDICATION FILE
|
|---|
| 27 | ;X-REF NO LONGER USED
|
|---|
| 28 | Q S MCARX=$P(^PSDRUG(DA,2),U,3),MCARY=$F(MCARX,"M"),MCARX=$E(MCARX,1,MCARY-2)_$E(MCARX,MCARY,9999)
|
|---|
| 29 | S $P(^PSDRUG(DA,2),U,3)=MCARX K:^(2)?."^" ^(2)
|
|---|
| 30 | K ^PSDRUG("AIUM",$P(^PSDRUG(DA,0),U,1),DA)
|
|---|
| 31 | K MCARX,MCARY Q
|
|---|
| 32 | RBLD N CD,DA,II,XX
|
|---|
| 33 | F II=691,691.1,691.5,691.6,691.7,691.8,694,698,698.1,698.2,698.3,699,700,701 D RBLD1
|
|---|
| 34 | K II Q
|
|---|
| 35 | RBLD1 Q:'$D(^MCAR(II,"C")) F DA=0:0 S DA=$O(^MCAR(II,DA)) Q:DA'?1N.N S MCARCDIE="^MCAR("_II_"," D INIT I $D(MCARCDIE),$D(CD) D CONT1
|
|---|
| 36 | Q
|
|---|
