MCARPROC ;WISC/TJK,RCH-STORE PROCEDURES IN MEDICINE PATIENT FILE ;7/30/96 13:48
;;2.3;Medicine;;09/13/1996
INIT ;INITIALIZE VARIABLES
K XX S MCARCDIE=MCARCDIE_DA_",0)" I $P($G(@MCARCDIE),U,1)="" K MCARCDIE Q
S XX=$P(@MCARCDIE,U,1),CD=$P(@MCARCDIE,U,2) I CD="" K MCARCDIE,CD,XX
Q
CHGDTE ;CHANGE PROCEDURE DATE
Q:'$D(MCARCDIE) D INIT G END:'$D(CD) S MCAROLDT=X G OLDAC
CHGDTE1 ;SET "AC" CROSS-REFERENCE WITH NEW DATE
Q:'$D(MCARCDIE) D INIT G END:'$D(CD) S XX=X G CONT1
CHGPAT ;TRANSFER PROCEDURE FROM ONE PATIENT TO ANOTHER
Q:'$D(MCARCDIE) D INIT G END:'$D(XX),CONT
OLDAC K ^MCAR(690,"AC",CD,9999999.9999-MCAROLDT,$P($P(MCARCDIE,U,2),",",1),DA) Q
CONT ;NEW PROCEDURE
S CD=X
CONT1 ;STORE PROCEDURE IN "AC" CROSS REFERENCE OF MEDICINE PATIENT FILE
S ^MCAR(690,"AC",CD,9999999.9999-XX,$P($P(MCARCDIE,U,2),",",1),DA)=""
END K MCARCDIE,CD,XX,MCAROLDT
Q
KILL S CD=X,MCAROLDT=MCARCDIE_DA_",0)",MCAROLDT=$P(@MCAROLDT,U,1) D OLDAC K MCAROLDT,CD Q
Q
MEDSET ;THIS SECTION SETS MEDICINE CODE AND CROSS-REFERENCE IN DRUG FILE
;X-REF NO LONGER USED
Q S $P(^PSDRUG(DA,2),U,3)=$S('$D(^PSDRUG(DA,2)):"M",1:$P(^(2),U,3)_"M")
S ^PSDRUG("AIUM",$P(^PSDRUG(DA,0),U,1),DA)="" Q
MEDKILL ;THIS SECTION DELETES MEDICINE CODE WHEN MEDICATION DELETED FROM MEDICATION FILE
;X-REF NO LONGER USED
Q S MCARX=$P(^PSDRUG(DA,2),U,3),MCARY=$F(MCARX,"M"),MCARX=$E(MCARX,1,MCARY-2)_$E(MCARX,MCARY,9999)
S $P(^PSDRUG(DA,2),U,3)=MCARX K:^(2)?."^" ^(2)
K ^PSDRUG("AIUM",$P(^PSDRUG(DA,0),U,1),DA)
K MCARX,MCARY Q
RBLD N CD,DA,II,XX
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
K II Q
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARPROC 1781 printed Apr 09, 2024@21:17:08 Page 2
MCARPROC ;WISC/TJK,RCH-STORE PROCEDURES IN MEDICINE PATIENT FILE ;7/30/96 13:48
+1 ;;2.3;Medicine;;09/13/1996
INIT ;INITIALIZE VARIABLES
+1 KILL XX
SET MCARCDIE=MCARCDIE_DA_",0)"
IF $PIECE($GET(@MCARCDIE),U,1)=""
KILL MCARCDIE
QUIT
+2 SET XX=$PIECE(@MCARCDIE,U,1)
SET CD=$PIECE(@MCARCDIE,U,2)
IF CD=""
KILL MCARCDIE,CD,XX
+3 QUIT
CHGDTE ;CHANGE PROCEDURE DATE
+1 if '$DATA(MCARCDIE)
QUIT
DO INIT
if '$DATA(CD)
GOTO END
SET MCAROLDT=X
GOTO OLDAC
CHGDTE1 ;SET "AC" CROSS-REFERENCE WITH NEW DATE
+1 if '$DATA(MCARCDIE)
QUIT
DO INIT
if '$DATA(CD)
GOTO END
SET XX=X
GOTO CONT1
CHGPAT ;TRANSFER PROCEDURE FROM ONE PATIENT TO ANOTHER
+1 if '$DATA(MCARCDIE)
QUIT
DO INIT
if '$DATA(XX)
GOTO END
GOTO CONT
OLDAC KILL ^MCAR(690,"AC",CD,9999999.9999-MCAROLDT,$PIECE($PIECE(MCARCDIE,U,2),",",1),DA)
QUIT
CONT ;NEW PROCEDURE
+1 SET CD=X
CONT1 ;STORE PROCEDURE IN "AC" CROSS REFERENCE OF MEDICINE PATIENT FILE
+1 SET ^MCAR(690,"AC",CD,9999999.9999-XX,$PIECE($PIECE(MCARCDIE,U,2),",",1),DA)=""
END KILL MCARCDIE,CD,XX,MCAROLDT
+1 QUIT
KILL SET CD=X
SET MCAROLDT=MCARCDIE_DA_",0)"
SET MCAROLDT=$PIECE(@MCAROLDT,U,1)
DO OLDAC
KILL MCAROLDT,CD
QUIT
+1 QUIT
MEDSET ;THIS SECTION SETS MEDICINE CODE AND CROSS-REFERENCE IN DRUG FILE
+1 ;X-REF NO LONGER USED
+2 QUIT
SET $PIECE(^PSDRUG(DA,2),U,3)=$SELECT('$DATA(^PSDRUG(DA,2)):"M",1:$PIECE(^(2),U,3)_"M")
+3 SET ^PSDRUG("AIUM",$PIECE(^PSDRUG(DA,0),U,1),DA)=""
QUIT
MEDKILL ;THIS SECTION DELETES MEDICINE CODE WHEN MEDICATION DELETED FROM MEDICATION FILE
+1 ;X-REF NO LONGER USED
+2 QUIT
SET MCARX=$PIECE(^PSDRUG(DA,2),U,3)
SET MCARY=$FIND(MCARX,"M")
SET MCARX=$EXTRACT(MCARX,1,MCARY-2)_$EXTRACT(MCARX,MCARY,9999)
+3 SET $PIECE(^PSDRUG(DA,2),U,3)=MCARX
if ^(2)?."^"
KILL ^(2)
+4 KILL ^PSDRUG("AIUM",$PIECE(^PSDRUG(DA,0),U,1),DA)
+5 KILL MCARX,MCARY
QUIT
RBLD NEW CD,DA,II,XX
+1 FOR II=691,691.1,691.5,691.6,691.7,691.8,694,698,698.1,698.2,698.3,699,700,701
DO RBLD1
+2 KILL II
QUIT
RBLD1 if '$DATA(^MCAR(II,"C"))
QUIT
FOR DA=0:0
SET DA=$ORDER(^MCAR(II,DA))
if DA'?1N.N
QUIT
SET MCARCDIE="^MCAR("_II_","
DO INIT
IF $DATA(MCARCDIE)
IF $DATA(CD)
DO CONT1
+1 QUIT
