ACMADDM1 ; IHS/TUCSON/TMJ - CONTINUATION OF ADD IHS DM REGISTER ; [ 07/07/1999 4:00 PM ]
;;2.0;ACM CASE MANAGEMENT SYSTEM;*1*;JAN 10, 1996
;This routine allows the user to conver existing register data
;to IHS standard data.
;ROUTINE IS CALLED FROM ACMADDM AND ENTERED VIA TAG CDIAG OR CCOMP
Q
;
CDIAG ;EP;CONVERTS USER DIAGNOSES TO IHS STANDARD DIAGNOSES
W !,"I will now check your patient's diagnoses against the IHS standards:"
SETD ;FINDS STANDARD DIAGNOSIS AND PUT IN ^TMP($J,"STD"
K ACME S (ACMDIR,ACME)="" F I=1:1 S ACME=$T(DIAG+I^ACMRGA01) Q:ACME["*" S ACME=$P(ACME,";;",3),ACMD="",ACMD=$O(^ACM(44.1,"B",ACME,ACMD)),^TMP($J,"STD",ACMD)=ACME,ACMDIR=ACMDIR_I_":"_ACME_";"
S ACMDIR=ACMDIR_I_":DELETE ENTIRELY;"
S ACMDIR=ACMDIR_(I+1)_":LEAVE AS IS"
;
FINDD ;FINDS REGISTER DIAGNOSIS AND PUT IN ^TMP($J,"REG"
S ACME="" F I=1:1 S ACME=$O(^ACM(44,"E",ACMRG,ACME)) Q:ACME="" S ACMD=$P(^ACM(44,ACME,0),U,1) I '$D(^TMP($J,"STD",ACMD)) S:'$D(^TMP($J,"REG",ACMD)) ^TMP($J,"REG",ACMD)="" S ^TMP($J,"REG",ACMD,ACME)=ACME_U_ACMD_U_$P(^ACM(44.1,ACMD,0),U,1)
S ACMD="",ACMQ=0 F S ACMD=$O(^TMP($J,"REG",ACMD)) Q:ACMD="" D MATCHD Q:ACMQ
Q:ACMQ
D:$D(^TMP($J,"REG")) DIRYND
D END
Q
DIRYND S DIR(0)="YO",DIR("A")="Are you ready to change your patient's diagnoses to the new diagnoses",DIR("B")="YES"
W ! D ^DIR K DIR Q:Y=0!(Y["^") I Y=1 D CHGD
Q
CHGD ;LOOPS AND CHANGES DIAGNOSES TO NEW VALUES
W !,"Changing diagnosis..." S ACMD="" F S ACMD=$O(^TMP($J,"REG",ACMD)) Q:ACMD="" D CHGD1
Q
CHGD1 Q:^TMP($J,"REG",ACMD)="LEAVE AS IS"
I ^TMP($J,"REG",ACMD)="DELETE ENTIRELY" D CHGDD Q
S ACME="" F S ACME=$O(^TMP($J,"REG",ACMD,ACME)) Q:ACME="" S DIE="^ACM(44,",DA=ACME,DR=".01///^S X=^TMP($J,""REG"",ACMD);.04///^S X=ACMRG" D ^DIE K DA,DR W "."
K ^ACM(44,"AC") S DIK="^ACM(44,",DIK(1)=".04^AC" D ENALL^DIK K DIK
Q
;
CHGDD ;
S ACMX=0 F S ACMX=$O(^ACM(44,"B",ACMD,ACMX)) Q:+ACMX=0 S DA=ACMX,DIK="^ACM(44," D ^DIK K DIK,DA W "."
S DIK="^ACM(44.1,"_ACMD_",""RG"",",DA(1)=ACMD,DA=ACMRG D ^DIK K DA,DA(1),DIK
I '$D(^ACM(44.1,ACMD,"RG","B")) S DIK="^ACM(44.1,",DA=ACMD D ^DIK K DA,DIK
Q
MATCHD ;
W !,"Choose a new diagnosis from the list below:",!
W !,"for your diagnosis: ",$P(^ACM(44.1,ACMD,0),U,1)
S DIR(0)="S^"_ACMDIR,DIR("A")="Choose a Diagnosis: " D ^DIR
I Y="" S ^TMP($J,"REG",ACMD)="LEAVE AS IS" Q
I Y["^" S ACMQ=1 Q
S ^TMP($J,"REG",ACMD)=Y(0) Q
Q
;
CCOMP ;EP;CONVERTS USER COMPLICATIONS TO IHS STANDARD COMPLICATIONS
W !,"I will now check your patient's complications against the IHS standards:"
;
SETC ;FINDS STANDARD COMPLICATIONS AND PUT IN ^TMP($J,"STD"
K ACME S (ACMDIR,ACME)="" F I=1:1 S ACME=$T(COMP+I^ACMRGA01) Q:ACME["*" S ACME=$P(ACME,";;",3),ACMD="",ACMD=$O(^ACM(42.1,"B",ACME,ACMD)),^TMP($J,"STD",ACMD)=ACME,ACMDIR=ACMDIR_I_":"_ACME_";"
S ACMDIR=ACMDIR_I_":DELETE ENTIRELY;"
S ACMDIR=ACMDIR_(I+1)_":LEAVE AS IS"
;
FINDC ;FINDS REGISTER COMPLICATION AND PUT IN ^TMP($J,"REG"
S ACME="" F I=1:1 S ACME=$O(^ACM(42,"E",ACMRG,ACME)) Q:ACME="" S ACMD=$P(^ACM(42,ACME,0),U,1) I '$D(^TMP($J,"STD",ACMD)) S:'$D(^TMP($J,"REG",ACMD)) ^TMP($J,"REG",ACMD)="" S ^TMP($J,"REG",ACMD,ACME)=ACME_U_ACMD_U_$P(^ACM(42.1,ACMD,0),U,1)
S ACMD="",ACMQ=0 F S ACMD=$O(^TMP($J,"REG",ACMD)) Q:ACMD="" D MATCHC Q:ACMQ
Q:ACMQ
D:$D(^TMP($J,"REG")) DIRYNC
D END
Q
DIRYNC S DIR(0)="YO",DIR("A")="Are you ready to change your patient's complications to the new complications",DIR("B")="YES"
W ! D ^DIR K DIR Q:Y=0!(Y["^") I Y=1 D CHGC
Q
;
CHGC ;LOOPS AND CHANGES COMPLICATIONS TO NEW VALUES
W !,"Changing complication..." S ACMD="" F S ACMD=$O(^TMP($J,"REG",ACMD)) Q:ACMD="" D CHGC1
Q
CHGC1 Q:^TMP($J,"REG",ACMD)="LEAVE AS IS"
I ^TMP($J,"REG",ACMD)="DELETE ENTIRELY" D CHGCD Q
S ACME="" F S ACME=$O(^TMP($J,"REG",ACMD,ACME)) Q:ACME="" S DIE="^ACM(42,",DA=ACME,DR=".01///^S X=^TMP($J,""REG"",ACMD);.04///^S X=ACMRG" D ^DIE K DA,DR W "."
K ^ACM(42,"AC") S DIK="^ACM(42,",DIK(1)=".04^AC" D ENALL^DIK K DIK
Q
;
CHGCD ;
S ACMX=0 F S ACMX=$O(^ACM(42,"B",ACMD,ACMX)) Q:+ACMX=0 S DA=ACMX,DIK="^ACM(42," D ^DIK K DIK,DA W "."
S DIK="^ACM(42.1,"_ACMD_",""RG"",",DA(1)=ACMD,DA=ACMRG D ^DIK K DA,DA(1),DIK
I '$D(^ACM(42.1,ACMD,"RG","B")) S DIK="^ACM(42.1,",DA=ACMD D ^DIK K DA,DIK
Q
MATCHC ;MATCHES COMPLICATION TO STD
W !,"Choose a new complication from the list below:",!
W !,"for your complication: ",$P(^ACM(42.1,ACMD,0),U,1)
S DIR(0)="S^"_ACMDIR,DIR("A")="Choose a Complication: " D ^DIR
I Y="" S ^TMP($J,"REG",ACMD)="LEAVE AS IS" Q
I Y["^" S ACMQ=1 Q
S ^TMP($J,"REG",ACMD)=Y(0) Q
Q
;
END ;CLEANUP IHS/OHPRD/TMJ Patch #1 - Removed Kill ACMQ
K ^TMP($J,"REG"),^TMP($J,"STD"),ACMD,ACMDIR,ACME,DA,DIE,DIR,DR,I
Q
ACMADDM1 ; IHS/TUCSON/TMJ - CONTINUATION OF ADD IHS DM REGISTER ; [ 07/07/1999 4:00 PM ]
+1 ;;2.0;ACM CASE MANAGEMENT SYSTEM;*1*;JAN 10, 1996
+2 ;This routine allows the user to conver existing register data
+3 ;to IHS standard data.
+4 ;ROUTINE IS CALLED FROM ACMADDM AND ENTERED VIA TAG CDIAG OR CCOMP
+5 QUIT
+6 ;
CDIAG ;EP;CONVERTS USER DIAGNOSES TO IHS STANDARD DIAGNOSES
+1 WRITE !,"I will now check your patient's diagnoses against the IHS standards:"
SETD ;FINDS STANDARD DIAGNOSIS AND PUT IN ^TMP($J,"STD"
+1 KILL ACME
SET (ACMDIR,ACME)=""
FOR I=1:1
SET ACME=$TEXT(DIAG+I^ACMRGA01)
IF ACME["*"
QUIT
SET ACME=$PIECE(ACME,";;",3)
SET ACMD=""
SET ACMD=$ORDER(^ACM(44.1,"B",ACME,ACMD))
SET ^TMP($JOB,"STD",ACMD)=ACME
SET ACMDIR=ACMDIR_I_":"_ACME_";"
+2 SET ACMDIR=ACMDIR_I_":DELETE ENTIRELY;"
+3 SET ACMDIR=ACMDIR_(I+1)_":LEAVE AS IS"
+4 ;
FINDD ;FINDS REGISTER DIAGNOSIS AND PUT IN ^TMP($J,"REG"
+1 SET ACME=""
FOR I=1:1
SET ACME=$ORDER(^ACM(44,"E",ACMRG,ACME))
IF ACME=""
QUIT
SET ACMD=$PIECE(^ACM(44,ACME,0),U,1)
IF '$DATA(^TMP($JOB,"STD",ACMD))
IF '$DATA(^TMP($JOB,"REG",ACMD))
SET ^TMP($JOB,"REG",ACMD)=""
SET ^TMP($JOB,"REG",ACMD,ACME)=ACME_U_ACMD_U_$PIECE(^ACM(44.1,ACMD,0),U,1)
+2 SET ACMD=""
SET ACMQ=0
FOR
SET ACMD=$ORDER(^TMP($JOB,"REG",ACMD))
IF ACMD=""
QUIT
DO MATCHD
IF ACMQ
QUIT
+3 IF ACMQ
QUIT
+4 IF $DATA(^TMP($JOB,"REG"))
DO DIRYND
+5 DO END
+6 QUIT
DIRYND SET DIR(0)="YO"
SET DIR("A")="Are you ready to change your patient's diagnoses to the new diagnoses"
SET DIR("B")="YES"
+1 WRITE !
DO ^DIR
KILL DIR
IF Y=0!(Y["^")
QUIT
IF Y=1
DO CHGD
+2 QUIT
CHGD ;LOOPS AND CHANGES DIAGNOSES TO NEW VALUES
+1 WRITE !,"Changing diagnosis..."
SET ACMD=""
FOR
SET ACMD=$ORDER(^TMP($JOB,"REG",ACMD))
IF ACMD=""
QUIT
DO CHGD1
+2 QUIT
CHGD1 IF ^TMP($JOB,"REG",ACMD)="LEAVE AS IS"
QUIT
+1 IF ^TMP($JOB,"REG",ACMD)="DELETE ENTIRELY"
DO CHGDD
QUIT
+2 SET ACME=""
FOR
SET ACME=$ORDER(^TMP($JOB,"REG",ACMD,ACME))
IF ACME=""
QUIT
SET DIE="^ACM(44,"
SET DA=ACME
SET DR=".01///^S X=^TMP($J,""REG"",ACMD);.04///^S X=ACMRG"
DO ^DIE
KILL DA,DR
WRITE "."
+3 KILL ^ACM(44,"AC")
SET DIK="^ACM(44,"
SET DIK(1)=".04^AC"
DO ENALL^DIK
KILL DIK
+4 QUIT
+5 ;
CHGDD ;
+1 SET ACMX=0
FOR
SET ACMX=$ORDER(^ACM(44,"B",ACMD,ACMX))
IF +ACMX=0
QUIT
SET DA=ACMX
SET DIK="^ACM(44,"
DO ^DIK
KILL DIK,DA
WRITE "."
+2 SET DIK="^ACM(44.1,"_ACMD_",""RG"","
SET DA(1)=ACMD
SET DA=ACMRG
DO ^DIK
KILL DA,DA(1),DIK
+3 IF '$DATA(^ACM(44.1,ACMD,"RG","B"))
SET DIK="^ACM(44.1,"
SET DA=ACMD
DO ^DIK
KILL DA,DIK
+4 QUIT
MATCHD ;
+1 WRITE !,"Choose a new diagnosis from the list below:",!
+2 WRITE !,"for your diagnosis: ",$PIECE(^ACM(44.1,ACMD,0),U,1)
+3 SET DIR(0)="S^"_ACMDIR
SET DIR("A")="Choose a Diagnosis: "
DO ^DIR
+4 IF Y=""
SET ^TMP($JOB,"REG",ACMD)="LEAVE AS IS"
QUIT
+5 IF Y["^"
SET ACMQ=1
QUIT
+6 SET ^TMP($JOB,"REG",ACMD)=Y(0)
QUIT
+7 QUIT
+8 ;
CCOMP ;EP;CONVERTS USER COMPLICATIONS TO IHS STANDARD COMPLICATIONS
+1 WRITE !,"I will now check your patient's complications against the IHS standards:"
+2 ;
SETC ;FINDS STANDARD COMPLICATIONS AND PUT IN ^TMP($J,"STD"
+1 KILL ACME
SET (ACMDIR,ACME)=""
FOR I=1:1
SET ACME=$TEXT(COMP+I^ACMRGA01)
IF ACME["*"
QUIT
SET ACME=$PIECE(ACME,";;",3)
SET ACMD=""
SET ACMD=$ORDER(^ACM(42.1,"B",ACME,ACMD))
SET ^TMP($JOB,"STD",ACMD)=ACME
SET ACMDIR=ACMDIR_I_":"_ACME_";"
+2 SET ACMDIR=ACMDIR_I_":DELETE ENTIRELY;"
+3 SET ACMDIR=ACMDIR_(I+1)_":LEAVE AS IS"
+4 ;
FINDC ;FINDS REGISTER COMPLICATION AND PUT IN ^TMP($J,"REG"
+1 SET ACME=""
FOR I=1:1
SET ACME=$ORDER(^ACM(42,"E",ACMRG,ACME))
IF ACME=""
QUIT
SET ACMD=$PIECE(^ACM(42,ACME,0),U,1)
IF '$DATA(^TMP($JOB,"STD",ACMD))
IF '$DATA(^TMP($JOB,"REG",ACMD))
SET ^TMP($JOB,"REG",ACMD)=""
SET ^TMP($JOB,"REG",ACMD,ACME)=ACME_U_ACMD_U_$PIECE(^ACM(42.1,ACMD,0),U,1)
+2 SET ACMD=""
SET ACMQ=0
FOR
SET ACMD=$ORDER(^TMP($JOB,"REG",ACMD))
IF ACMD=""
QUIT
DO MATCHC
IF ACMQ
QUIT
+3 IF ACMQ
QUIT
+4 IF $DATA(^TMP($JOB,"REG"))
DO DIRYNC
+5 DO END
+6 QUIT
DIRYNC SET DIR(0)="YO"
SET DIR("A")="Are you ready to change your patient's complications to the new complications"
SET DIR("B")="YES"
+1 WRITE !
DO ^DIR
KILL DIR
IF Y=0!(Y["^")
QUIT
IF Y=1
DO CHGC
+2 QUIT
+3 ;
CHGC ;LOOPS AND CHANGES COMPLICATIONS TO NEW VALUES
+1 WRITE !,"Changing complication..."
SET ACMD=""
FOR
SET ACMD=$ORDER(^TMP($JOB,"REG",ACMD))
IF ACMD=""
QUIT
DO CHGC1
+2 QUIT
CHGC1 IF ^TMP($JOB,"REG",ACMD)="LEAVE AS IS"
QUIT
+1 IF ^TMP($JOB,"REG",ACMD)="DELETE ENTIRELY"
DO CHGCD
QUIT
+2 SET ACME=""
FOR
SET ACME=$ORDER(^TMP($JOB,"REG",ACMD,ACME))
IF ACME=""
QUIT
SET DIE="^ACM(42,"
SET DA=ACME
SET DR=".01///^S X=^TMP($J,""REG"",ACMD);.04///^S X=ACMRG"
DO ^DIE
KILL DA,DR
WRITE "."
+3 KILL ^ACM(42,"AC")
SET DIK="^ACM(42,"
SET DIK(1)=".04^AC"
DO ENALL^DIK
KILL DIK
+4 QUIT
+5 ;
CHGCD ;
+1 SET ACMX=0
FOR
SET ACMX=$ORDER(^ACM(42,"B",ACMD,ACMX))
IF +ACMX=0
QUIT
SET DA=ACMX
SET DIK="^ACM(42,"
DO ^DIK
KILL DIK,DA
WRITE "."
+2 SET DIK="^ACM(42.1,"_ACMD_",""RG"","
SET DA(1)=ACMD
SET DA=ACMRG
DO ^DIK
KILL DA,DA(1),DIK
+3 IF '$DATA(^ACM(42.1,ACMD,"RG","B"))
SET DIK="^ACM(42.1,"
SET DA=ACMD
DO ^DIK
KILL DA,DIK
+4 QUIT
MATCHC ;MATCHES COMPLICATION TO STD
+1 WRITE !,"Choose a new complication from the list below:",!
+2 WRITE !,"for your complication: ",$PIECE(^ACM(42.1,ACMD,0),U,1)
+3 SET DIR(0)="S^"_ACMDIR
SET DIR("A")="Choose a Complication: "
DO ^DIR
+4 IF Y=""
SET ^TMP($JOB,"REG",ACMD)="LEAVE AS IS"
QUIT
+5 IF Y["^"
SET ACMQ=1
QUIT
+6 SET ^TMP($JOB,"REG",ACMD)=Y(0)
QUIT
+7 QUIT
+8 ;
END ;CLEANUP IHS/OHPRD/TMJ Patch #1 - Removed Kill ACMQ
+1 KILL ^TMP($JOB,"REG"),^TMP($JOB,"STD"),ACMD,ACMDIR,ACME,DA,DIE,DIR,DR,I
+2 QUIT
