ACMADDM2 ; IHS/TUCSON/TMJ - CONTINUATION OF ADD IHS PRE-DIABETES REGISTER ; [ 10/17/05 11:49 AM ]
;;2.0;ACM CASE MANAGEMENT SYSTEM;*6*;JAN 10, 1996
;This routine allows the user to convert existing Pre-Diabetes Register data
;to IHS standard data.
;IHS/CMI/TMJ - PATCH #6 - INSTALL NEW PRE-DIABETES REGISTER
;ROUTINE IS CALLED FROM ACMADDMP AND ENTERED VIA TAG CDIAG OR CCOMP
;OR CRISK OR CDXCR - DX - COMPLICATIONS - RISK FACTORS - DX CRITERIA
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^ACMRGA02) 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^ACMRGA02) 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
;
;
CRISK ;EP;FINDS STANDARD RISK FACTORS AND PUT IN ^TMP($J,"STD"
W !,"I will now check your patient's Risk Factors against the IHS standards:"
;
;
SETR ;FINDS THE STANDARDS AND PUTS IN ^TMP($J,"STD"
K ACME S (ACMDIR,ACME)="" F I=1:1 S ACME=$T(RISK+I^ACMRGA02) Q:ACME["*" S ACME=$P(ACME,";;",3),ACMD="",ACMD=$O(^ACM(45.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"
;
FINDR ;
S ACME="" F I=1:1 S ACME=$O(^ACM(45,"E",ACMRG,ACME)) Q:ACME="" S ACMD=$P(^ACM(45,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(45.1,ACMD,0),U,1)
S ACMD="",ACMQ=0 F S ACMD=$O(^TMP($J,"REG",ACMD)) Q:ACMD="" D MATCHR Q:ACMQ
Q:ACMQ
D:$D(^TMP($J,"REG")) DIRYNR
D END
Q
;
DIRYNR S DIR(0)="YO",DIR("A")="Are you ready to change your patient's Risk Factors to the new Risk Factors",DIR("B")="YES"
W ! D ^DIR K DIR Q:Y=0!(Y["^") I Y=1 D CHGR
Q
CHGR ;
W !,"Changing Risk Factors..." S ACMD="" F S ACMD=$O(^TMP($J,"REG",ACMD)) Q:ACMD="" D CHGR1
Q
;
CHGR1 Q:^TMP($J,"REG",ACMD)="LEAVE AS IS"
I ^TMP($J,"REG",ACMD)="DELETE ENTIRELY" D CHGRD Q
S ACME="" F S ACME=$O(^TMP($J,"REG",ACMD,ACME)) Q:ACME="" S DIE="^ACM(45,",DA=ACME,DR=".01///^S X=^TMP($J,""REG"",ACMD);.04///^S X=ACMRG" D ^DIE K DA,DR W "."
K ^ACM(45,"AC") S DIK="^ACM(45,",DIK(1)=".04^AC" D ENALL^DIK K DIK
Q
;
CHGRD ;
S ACMX=0 F S ACMX=$O(^ACM(45,"B",ACMD,ACMX)) Q:+ACMX=0 S DA=ACMX,DIK="^ACM(45," D ^DIK K DIK,DA W "."
S DIK="^ACM(45.1,"_ACMD_",""RG"",",DA(1)=ACMD,DA=ACMRG D ^DIK K DA,DA(1),DIK
I '$D(^ACM(45.1,ACMD,"RG","B")) S DIK="^ACM(45.1,",DA=ACMD D ^DIK K DA,DIK
Q
;
MATCHR ;
W !,"Choose a new Risk Factor from the list below:",!
W !,"for your Risk Factor: ",$P(^ACM(45.1,ACMD,0),U,1)
S DIR(0)="S^"_ACMDIR,DIR("A")="Choose a Risk Factor: " 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
;
;
CDXCR ;EP;CONVERT DIAGNOSTIC CRITERIA TO STANDARD
W !,"I will now check your patient's Diagnostic Criteria agains the IHS Standards:"
;
SETDC ;FINDS STANDARD DX CRITERIA AND PUT IN ^TMP($J,"STD"
K ACME S (ACMDIR,ACME)="" F I=1:1 S ACME=$T(DXCRIT+I^ACMRGA02) Q:ACME["*" S ACME=$P(ACME,";;",3),ACMD="",ACMD=$O(^ACM(51.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"
;
FINDDC ;FINDS REGISTER DX CRIERIA AND PUT IN TMP($J,"REG"
S ACME="" F I=1:1 S ACME=$O(^ACM(51,"E",ACMRG,ACME)) Q:ACME="" S ACMD=$P(^ACM(51,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(51.1,ACMD,0),U,1)
S ACMD="",ACMQ=0 F S ACMD=$O(^TMP($J,"REG",ACMD)) Q:ACMD="" D MATCHDC Q:ACMQ
Q:ACMQ
D:$D(^TMP($J,"REG")) DIRYNDC
D END
Q
;
DIRYNDC S DIR(0)="YO",DIR("A")="Are you ready to change your patient's Diagnostic Criteria to the new Standard",DIR("B")="YES"
W ! D ^DIR K DIR Q:Y=0!(Y["^") I Y=1 D CHGDC
Q
CHGDC ;LOOPS & CHANGES DX CRITERIA TO NEW VALUES
W !,"Changing Diagnostic Criteria..." S ACMD="" F S ACMD=$O(^TMP($J,"REG",ACMD)) Q:ACMD="" D CHGDC1
Q
;
CHGDC1 Q:^TMP($J,"REG",ACMD)="LEAVE AS IS"
I ^TMP($J,"REG",ACMD)="DELETE ENTIRELY" D CHGDCD Q
S ACME="" F S ACME=$O(^TMP($J,"REG",ACMD,ACME)) Q:ACME="" S DIE="^ACM(51,",DA=ACME,DR=".01///^S X=^TMP($J,""REG"",ACMD);.04///^S X=ACMRG" D ^DIE K DA,DR W "."
K ^ACM(51,"AC") S DIK="^ACM(51,",DIK(1)=".04^AC" D ENALL^DIK K DIK
Q
;
CHGDCD ;
S ACMX=0 F S ACMX=$O(^ACM(51,"B",ACMD,ACMX)) Q:+ACMX=0 S DA=ACMX,DIK="^ACM(51," D ^DIK K DIK,DA W "."
S DIK="^ACM(51.1,"_ACMD_",""RG"",",DA(1)=ACMD,DA=ACMRG D ^DIK K DA,DA(1),DIK
I '$D(^ACM(51.1,ACMD,"RG","B")) S DIK="^ACM(51.1,",DA=ACMD D ^DIK K DA,DIK
Q
;
MATCHDC ;
W !,"Choose a new Diagnostic Criteria from the list below:",!
W !,"for your Diagnostic Criteria: ",$P(^ACM(51.1,ACMD,0),U,1)
S DIR(0)="S^"_ACMDIR,DIR("A")="Choose a Diagnostic Criteria: " 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
ACMADDM2 ; IHS/TUCSON/TMJ - CONTINUATION OF ADD IHS PRE-DIABETES REGISTER ; [ 10/17/05 11:49 AM ]
+1 ;;2.0;ACM CASE MANAGEMENT SYSTEM;*6*;JAN 10, 1996
+2 ;This routine allows the user to convert existing Pre-Diabetes Register data
+3 ;to IHS standard data.
+4 ;IHS/CMI/TMJ - PATCH #6 - INSTALL NEW PRE-DIABETES REGISTER
+5 ;ROUTINE IS CALLED FROM ACMADDMP AND ENTERED VIA TAG CDIAG OR CCOMP
+6 ;OR CRISK OR CDXCR - DX - COMPLICATIONS - RISK FACTORS - DX CRITERIA
+7 QUIT
+8 ;
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^ACMRGA02)
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^ACMRGA02)
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 ;
+9 ;
CRISK ;EP;FINDS STANDARD RISK FACTORS AND PUT IN ^TMP($J,"STD"
+1 WRITE !,"I will now check your patient's Risk Factors against the IHS standards:"
+2 ;
+3 ;
SETR ;FINDS THE STANDARDS AND PUTS IN ^TMP($J,"STD"
+1 KILL ACME
SET (ACMDIR,ACME)=""
FOR I=1:1
SET ACME=$TEXT(RISK+I^ACMRGA02)
IF ACME["*"
QUIT
SET ACME=$PIECE(ACME,";;",3)
SET ACMD=""
SET ACMD=$ORDER(^ACM(45.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 ;
FINDR ;
+1 SET ACME=""
FOR I=1:1
SET ACME=$ORDER(^ACM(45,"E",ACMRG,ACME))
IF ACME=""
QUIT
SET ACMD=$PIECE(^ACM(45,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(45.1,ACMD,0),U,1)
+2 SET ACMD=""
SET ACMQ=0
FOR
SET ACMD=$ORDER(^TMP($JOB,"REG",ACMD))
IF ACMD=""
QUIT
DO MATCHR
IF ACMQ
QUIT
+3 IF ACMQ
QUIT
+4 IF $DATA(^TMP($JOB,"REG"))
DO DIRYNR
+5 DO END
+6 QUIT
+7 ;
DIRYNR SET DIR(0)="YO"
SET DIR("A")="Are you ready to change your patient's Risk Factors to the new Risk Factors"
SET DIR("B")="YES"
+1 WRITE !
DO ^DIR
KILL DIR
IF Y=0!(Y["^")
QUIT
IF Y=1
DO CHGR
+2 QUIT
CHGR ;
+1 WRITE !,"Changing Risk Factors..."
SET ACMD=""
FOR
SET ACMD=$ORDER(^TMP($JOB,"REG",ACMD))
IF ACMD=""
QUIT
DO CHGR1
+2 QUIT
+3 ;
CHGR1 IF ^TMP($JOB,"REG",ACMD)="LEAVE AS IS"
QUIT
+1 IF ^TMP($JOB,"REG",ACMD)="DELETE ENTIRELY"
DO CHGRD
QUIT
+2 SET ACME=""
FOR
SET ACME=$ORDER(^TMP($JOB,"REG",ACMD,ACME))
IF ACME=""
QUIT
SET DIE="^ACM(45,"
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(45,"AC")
SET DIK="^ACM(45,"
SET DIK(1)=".04^AC"
DO ENALL^DIK
KILL DIK
+4 QUIT
+5 ;
CHGRD ;
+1 SET ACMX=0
FOR
SET ACMX=$ORDER(^ACM(45,"B",ACMD,ACMX))
IF +ACMX=0
QUIT
SET DA=ACMX
SET DIK="^ACM(45,"
DO ^DIK
KILL DIK,DA
WRITE "."
+2 SET DIK="^ACM(45.1,"_ACMD_",""RG"","
SET DA(1)=ACMD
SET DA=ACMRG
DO ^DIK
KILL DA,DA(1),DIK
+3 IF '$DATA(^ACM(45.1,ACMD,"RG","B"))
SET DIK="^ACM(45.1,"
SET DA=ACMD
DO ^DIK
KILL DA,DIK
+4 QUIT
+5 ;
MATCHR ;
+1 WRITE !,"Choose a new Risk Factor from the list below:",!
+2 WRITE !,"for your Risk Factor: ",$PIECE(^ACM(45.1,ACMD,0),U,1)
+3 SET DIR(0)="S^"_ACMDIR
SET DIR("A")="Choose a Risk Factor: "
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 ;
+9 ;
CDXCR ;EP;CONVERT DIAGNOSTIC CRITERIA TO STANDARD
+1 WRITE !,"I will now check your patient's Diagnostic Criteria agains the IHS Standards:"
+2 ;
SETDC ;FINDS STANDARD DX CRITERIA AND PUT IN ^TMP($J,"STD"
+1 KILL ACME
SET (ACMDIR,ACME)=""
FOR I=1:1
SET ACME=$TEXT(DXCRIT+I^ACMRGA02)
IF ACME["*"
QUIT
SET ACME=$PIECE(ACME,";;",3)
SET ACMD=""
SET ACMD=$ORDER(^ACM(51.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 ;
FINDDC ;FINDS REGISTER DX CRIERIA AND PUT IN TMP($J,"REG"
+1 SET ACME=""
FOR I=1:1
SET ACME=$ORDER(^ACM(51,"E",ACMRG,ACME))
IF ACME=""
QUIT
SET ACMD=$PIECE(^ACM(51,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(51.1,ACMD,0),U,1)
+2 SET ACMD=""
SET ACMQ=0
FOR
SET ACMD=$ORDER(^TMP($JOB,"REG",ACMD))
IF ACMD=""
QUIT
DO MATCHDC
IF ACMQ
QUIT
+3 IF ACMQ
QUIT
+4 IF $DATA(^TMP($JOB,"REG"))
DO DIRYNDC
+5 DO END
+6 QUIT
+7 ;
DIRYNDC SET DIR(0)="YO"
SET DIR("A")="Are you ready to change your patient's Diagnostic Criteria to the new Standard"
SET DIR("B")="YES"
+1 WRITE !
DO ^DIR
KILL DIR
IF Y=0!(Y["^")
QUIT
IF Y=1
DO CHGDC
+2 QUIT
CHGDC ;LOOPS & CHANGES DX CRITERIA TO NEW VALUES
+1 WRITE !,"Changing Diagnostic Criteria..."
SET ACMD=""
FOR
SET ACMD=$ORDER(^TMP($JOB,"REG",ACMD))
IF ACMD=""
QUIT
DO CHGDC1
+2 QUIT
+3 ;
CHGDC1 IF ^TMP($JOB,"REG",ACMD)="LEAVE AS IS"
QUIT
+1 IF ^TMP($JOB,"REG",ACMD)="DELETE ENTIRELY"
DO CHGDCD
QUIT
+2 SET ACME=""
FOR
SET ACME=$ORDER(^TMP($JOB,"REG",ACMD,ACME))
IF ACME=""
QUIT
SET DIE="^ACM(51,"
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(51,"AC")
SET DIK="^ACM(51,"
SET DIK(1)=".04^AC"
DO ENALL^DIK
KILL DIK
+4 QUIT
+5 ;
CHGDCD ;
+1 SET ACMX=0
FOR
SET ACMX=$ORDER(^ACM(51,"B",ACMD,ACMX))
IF +ACMX=0
QUIT
SET DA=ACMX
SET DIK="^ACM(51,"
DO ^DIK
KILL DIK,DA
WRITE "."
+2 SET DIK="^ACM(51.1,"_ACMD_",""RG"","
SET DA(1)=ACMD
SET DA=ACMRG
DO ^DIK
KILL DA,DA(1),DIK
+3 IF '$DATA(^ACM(51.1,ACMD,"RG","B"))
SET DIK="^ACM(51.1,"
SET DA=ACMD
DO ^DIK
KILL DA,DIK
+4 QUIT
+5 ;
MATCHDC ;
+1 WRITE !,"Choose a new Diagnostic Criteria from the list below:",!
+2 WRITE !,"for your Diagnostic Criteria: ",$PIECE(^ACM(51.1,ACMD,0),U,1)
+3 SET DIR(0)="S^"_ACMDIR
SET DIR("A")="Choose a Diagnostic Criteria: "
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
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
