- 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
