- 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 Jan 18, 2025@03:15:38 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