MCARPROC.m

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

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