Routine: ACMEP

ACMEP ; IHS/TUCSON/TMJ - EDIT SEQUENCE DATA ENTRY ;

 ;;2.0;ACM CASE MANAGEMENT SYSTEM;;JAN 10, 1996

 ;EDITING SEQUENCE FOR PATIENT DATA ENTRY

 ;ENTRY DISPLAY OF EXISTING DATA

 ;HEADER DISPLAY FORMAT CALLED FROM ACMCTRL2

 ;ENTRY FIELD & POSITION NUMBER DISPLAYS CALLED FROM ACMCTRL1

EN D INIT

EN1 D HEAD

 G EXIT:$D(ACMPROB)

 D LIST:'$D(ACMCT)&'$D(ACMREG)

 I '$D(ACMREG),'$D(ACMCT),'$D(ACMNT),'$D(ACMCH) D DIC

 I $D(ACMDEL) K ACMDEL G EN1

 I '$D(ACMQUIT),'$D(ACMOUT) D DIE I ACMDIC=44,$D(ACMY),$D(^ACM(44.3,"AC",ACMY)) S DIR(0)="YO",DIR("A")="Add/Edit Standard Interventions",DIR("B")="NO" W ! D ^DIR K DIR I Y=1 S ACMDXDA=ACMY D EN2^ACMDXIT

 G EN1:'$D(ACMQUIT)&'$D(ACMOUT)&'$D(ACMCT)&'$D(ACMCH)&'$D(ACMCR)

EXIT K ACMPROB,ACMENTRY,ACMREG,ACMCT,ACMNT,ACMCH,ACMFM,ACMTL,ACMEN1,ACMY

 K ACMEN,ACMLE,ACMDIQF,ACMDIC,DIC,DR,DA,ACMPOSS,ACMDIQF,ACMDR,ACMDIC

 K ACMDIC1,ACMDIC2,ACMFLD,ACMUTIL,ACMDICK

INIT K ACMQUIT,ACMOUT

 I $D(ACMEP) S ACMEN1=$P(ACMENTRY," ;;")_1,ACMLE=$P($T(@ACMEN1^ACMCTRL2),";;",2)

 S ACMTL=$P(ACMENTRY,";;",2),ACMDIC=$P(ACMENTRY,";;",3),ACMDR=$P(ACMENTRY,";;",4),ACMDIQF=$P(ACMENTRY,";;",5),ACMPOSS=$P(ACMENTRY,";;",6)

DIC S DIC="^ACM("_ACMDIC_".1,",DIC("A")=$P(ACMENTRY,";;",7),DIC(0)="AEMQZL",ACMDIC1="^ACM("_ACMDIC_")",ACMDIC2="^ACM("_ACMDIC_".1)"

 S:ACMDIC["57" DIC="^AUTTMSR("

 S:$D(ACMFM) DIC="^AUPNPAT("

 I DIC["AUPNPAT"!(ACMDIC=47) S DIC(0)="AEMQZ"

 I $P(^ACM(41.1,ACMRG,0),U,11)'=1 S DIC(0)="AEMQZ"

 I '$P(^ACM(41.1,ACMRG,0),U,8) S:ACMDIC'=41&(ACMDIC'=46)&(ACMDIC'=57)&(ACMDIC'=50) DIC("S")="I $D(@ACMDIC2@(+Y,""RG"",""B"",ACMRG))"

 S:ACMDIC=47 DIC("S")="I $D(@ACMDIC2@(+Y,""RG"",""B"",ACMRG))"

W !

 D ^DIC K DIC,DA

 I $E(X)=U!(X="")!(Y=-1) S ACMQUIT="" S:X["^" ACMOUT="" Q

 S ACMY=+Y

 I $P(Y,U,3)=1 S DR=".02T;.03///"_ACMRGNA D ADD

 I '$D(@ACMDIC2@(ACMY,"RG","B",ACMRG)) S DR=".03///"_ACMRGNA D ADD

 I $D(@ACMDIC1@("AC",ACMRG,ACMPTNO,ACMY)) S DA=(^(ACMY)) D DEL Q

DICN ;EP

 K DIC,DD,DR

 S X=ACMY,DIC="^ACM("_ACMDIC_",",DIC(0)="L",DIC("DR")=".02////"_ACMPTNO_";.03////"_ACMRGDFN_";.04////"_ACMRG

 K DD,DO D FILE^DICN K DIC,DR,DD S (ACMDA,DA)=+Y

ADD S DIE="^ACM("_ACMDIC_".1,",DA=ACMY

 D ^DIE S Y=DA K DIE,DA,DR

DIE ;EP

 S:ACMDIC=41 DA=ACMRGDFN

 S DR=ACMDR,DIE="^ACM("_ACMDIC_","

 W:'$D(ACMREG)&'$D(ACMNT)&'$D(ACMCH) !

 D DIE1

DIE1 W ! D ^DIE K DIC,DIE,DA,DR

 I $D(Y) S ACMOUT="" Q

 S DIE="^ACM(41,",DA=ACMRGDFN,DR="11///TODAY" D ^DIE K DIC,DIE,DA,DR

DEL W !!?10,"Delete this entry"

 S %=2 D YN^DICN

 I %=-1 S ACMQUIT="" Q

 I %=0 W !!?10,"Type 'Y' to delete entry or 'N' to retain it." G DEL

 I %Y='"",(%Y'?1"Y".E)!(%Y'?1"N".E) W !!?10,"Type 'Y' to delete entry or 'N' to retain it." G DEL

 I %=2 Q

 S DIC="^ACM("_ACMDIC_",",X=+Y,DIC(0)="E"

 D ^DIC K DIC

 S DIE="^ACM("_ACMDIC_",",DR=".01///@"

 D DIE1 S ACMDEL=""

HEAD D HEAD^ACMMENU

 W !!?14,$S(ACMTL["PCC":"  View ",1:"Update "),@ACMRVON,ACMTL,@ACMRVOFF,!?17,"for ",@ACMRVON,ACMPTNA2,@ACMRVOFF

 X ACMLE

LIST S DIC="90022"_ACMDIC,ACMDIC1="^ACM("_ACMDIC_")",ACMDIC2="^ACM("_ACMDIC_","

 I ACMDIC=41 S DA=ACMRGDFN D LIST2 Q

 S ACMA=""

 F ACMI=0:0 S ACMA=$O(@ACMDIC1@("AC",ACMRG,ACMPTNO,ACMA)) Q:ACMA=""  S DA=^(ACMA) D LIST2

 S ACMDICK="90022"_ACMDIC

 K ^UTILITY("DIQ1",$J,ACMDICK),ACMA,ACMI,ACMDIC1

LIST2 S ACMCNT=$L(ACMDIQF,";"),DR=ACMDIQF

 D EN^DIQ1

 S ACMUTIL="^UTILITY(""DIQ1"""_","_$J_",90022"_ACMDIC_","_DA_")"

W !

 F ACMJ=1:1:ACMCNT S ACMFLD=$P(ACMDIQF,";",ACMJ),ACMPOS=$P(ACMPOSS,";",ACMJ)  D

 .S G=$P(ACMUTIL,")")_","_ACMFLD_",1)" I $D(@G) D WP Q

 .S ACMX=$S($D(@ACMUTIL@(ACMFLD)):^(ACMFLD),1:"") W:ACMX'="" ?ACMPOS,ACMX

.Q

 K ACMJ,ACMUTIL,ACMFLD,ACMPOS

WP ;Display of Word Processing Field

 K ^UTILITY($J,"W")

 S ACMG=$P(ACMUTIL,")")_","_ACMFLD_",ACMI)"

 S ACMI=0 F  S ACMI=$O(@ACMG)  Q:ACMI=""  D WP2

 D WPDISP

WP2 ;WP Length Format from 1-40 Characters rather than 80 standard

 S DIWL=1,DIWR=40,X=@ACMG D ^DIWP

WPDISP ;

 S Z=0 F  S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z  W ?ACMPOS,^UTILITY($J,"W",DIWL,Z,0),!

 K ^UTILITY($J,"W")

ACMEP     ; IHS/TUCSON/TMJ - EDIT SEQUENCE DATA ENTRY ;

 +1       ;;2.0;ACM CASE MANAGEMENT SYSTEM;;JAN 10, 1996

 +2       ;EDITING SEQUENCE FOR PATIENT DATA ENTRY

 +3       ;ENTRY DISPLAY OF EXISTING DATA

 +4       ;HEADER DISPLAY FORMAT CALLED FROM ACMCTRL2

 +5       ;ENTRY FIELD & POSITION NUMBER DISPLAYS CALLED FROM ACMCTRL1

 +6       ;

 +7       ;

EN         DO INIT

EN1        DO HEAD

 +1        IF $DATA(ACMPROB)

               GOTO EXIT

 +2        IF '$DATA(ACMCT)&'$DATA(ACMREG)

               DO LIST

 +3        IF '$DATA(ACMREG)

               IF '$DATA(ACMCT)

                   IF '$DATA(ACMNT)

                       IF '$DATA(ACMCH)

                           DO DIC

 +4        IF $DATA(ACMDEL)

               KILL ACMDEL

               GOTO EN1

 +5        IF '$DATA(ACMQUIT)

               IF '$DATA(ACMOUT)

                   DO DIE

                   IF ACMDIC=44

                       IF $DATA(ACMY)

                           IF $DATA(^ACM(44.3,"AC",ACMY))

                               SET DIR(0)="YO"

                               SET DIR("A")="Add/Edit Standard Interventions"

                               SET DIR("B")="NO"

                               WRITE !

                               DO ^DIR

                               KILL DIR

                               IF Y=1

                                   SET ACMDXDA=ACMY

                                   DO EN2^ACMDXIT

 +6        IF '$DATA(ACMQUIT)&'$DATA(ACMOUT)&'$DATA(ACMCT)&'$DATA(ACMCH)&'$DATA(ACMCR)

               GOTO EN1

EXIT       KILL ACMPROB,ACMENTRY,ACMREG,ACMCT,ACMNT,ACMCH,ACMFM,ACMTL,ACMEN1,ACMY

 +1        KILL ACMEN,ACMLE,ACMDIQF,ACMDIC,DIC,DR,DA,ACMPOSS,ACMDIQF,ACMDR,ACMDIC

 +2        KILL ACMDIC1,ACMDIC2,ACMFLD,ACMUTIL,ACMDICK

 +3        QUIT

 +4       ;

INIT       KILL ACMQUIT,ACMOUT

 +1        IF $DATA(ACMEP)

               SET ACMEN1=$PIECE(ACMENTRY," ;;")_1

               SET ACMLE=$PIECE($TEXT(@ACMEN1^ACMCTRL2),";;",2)

 +2        SET ACMTL=$PIECE(ACMENTRY,";;",2)

           SET ACMDIC=$PIECE(ACMENTRY,";;",3)

           SET ACMDR=$PIECE(ACMENTRY,";;",4)

           SET ACMDIQF=$PIECE(ACMENTRY,";;",5)

           SET ACMPOSS=$PIECE(ACMENTRY,";;",6)

 +3        QUIT

 +4       ;

DIC        SET DIC="^ACM("_ACMDIC_".1,"

           SET DIC("A")=$PIECE(ACMENTRY,";;",7)

           SET DIC(0)="AEMQZL"

           SET ACMDIC1="^ACM("_ACMDIC_")"

           SET ACMDIC2="^ACM("_ACMDIC_".1)"

 +1        IF ACMDIC["57"

               SET DIC="^AUTTMSR("

 +2        IF $DATA(ACMFM)

               SET DIC="^AUPNPAT("

 +3        IF DIC["AUPNPAT"!(ACMDIC=47)

               SET DIC(0)="AEMQZ"

 +4        IF $PIECE(^ACM(41.1,ACMRG,0),U,11)'=1

               SET DIC(0)="AEMQZ"

 +5        IF '$PIECE(^ACM(41.1,ACMRG,0),U,8)

               IF ACMDIC'=41&(ACMDIC'=46)&(ACMDIC'=57)&(ACMDIC'=50)

                   SET DIC("S")="I $D(@ACMDIC2@(+Y,""RG"",""B"",ACMRG))"

 +6        IF ACMDIC=47

               SET DIC("S")="I $D(@ACMDIC2@(+Y,""RG"",""B"",ACMRG))"

 +7        WRITE !

 +8        DO ^DIC

           KILL DIC,DA

 +9        IF $EXTRACT(X)=U!(X="")!(Y=-1)

               SET ACMQUIT=""

               IF X["^"

                   SET ACMOUT=""

               QUIT

 +10       SET ACMY=+Y

 +11       IF $PIECE(Y,U,3)=1

               SET DR=".02T;.03///"_ACMRGNA

               DO ADD

 +12       IF '$DATA(@ACMDIC2@(ACMY,"RG","B",ACMRG))

               SET DR=".03///"_ACMRGNA

               DO ADD

 +13       IF $DATA(@ACMDIC1@("AC",ACMRG,ACMPTNO,ACMY))

               SET DA=(^(ACMY))

               DO DEL

               QUIT

DICN      ;EP

 +1        KILL DIC,DD,DR

 +2        SET X=ACMY

           SET DIC="^ACM("_ACMDIC_","

           SET DIC(0)="L"

           SET DIC("DR")=".02////"_ACMPTNO_";.03////"_ACMRGDFN_";.04////"_ACMRG

 +3        KILL DD,DO

           DO FILE^DICN

           KILL DIC,DR,DD

           SET (ACMDA,DA)=+Y

 +4        QUIT

 +5       ;

ADD        SET DIE="^ACM("_ACMDIC_".1,"

           SET DA=ACMY

 +1        DO ^DIE

           SET Y=DA

           KILL DIE,DA,DR

 +2        QUIT

 +3       ;

DIE       ;EP

 +1        IF ACMDIC=41

               SET DA=ACMRGDFN

 +2        SET DR=ACMDR

           SET DIE="^ACM("_ACMDIC_","

 +3        IF '$DATA(ACMREG)&'$DATA(ACMNT)&'$DATA(ACMCH)

               WRITE !

 +4        DO DIE1

 +5        QUIT

 +6       ;

DIE1       WRITE !

           DO ^DIE

           KILL DIC,DIE,DA,DR

 +1        IF $DATA(Y)

               SET ACMOUT=""

               QUIT

 +2        SET DIE="^ACM(41,"

           SET DA=ACMRGDFN

           SET DR="11///TODAY"

           DO ^DIE

           KILL DIC,DIE,DA,DR

 +3        QUIT

 +4       ;

DEL        WRITE !!?10,"Delete this entry"

 +1        SET %=2

           DO YN^DICN

 +2        IF %=-1

               SET ACMQUIT=""

               QUIT

 +3        IF %=0

               WRITE !!?10,"Type 'Y' to delete entry or 'N' to retain it."

               GOTO DEL

 +4        IF %Y='""

               IF (%Y'?1"Y".E)!(%Y'?1"N".E)

                   WRITE !!?10,"Type 'Y' to delete entry or 'N' to retain it."

                   GOTO DEL

 +5        IF %=2

               QUIT

 +6        SET DIC="^ACM("_ACMDIC_","

           SET X=+Y

           SET DIC(0)="E"

 +7        DO ^DIC

           KILL DIC

 +8        SET DIE="^ACM("_ACMDIC_","

           SET DR=".01///@"

 +9        DO DIE1

           SET ACMDEL=""

 +10       QUIT

 +11      ;

HEAD       DO HEAD^ACMMENU

 +1        WRITE !!?14,$SELECT(ACMTL["PCC":"  View ",1:"Update "),@ACMRVON,ACMTL,@ACMRVOFF,!?17,"for ",@ACMRVON,ACMPTNA2,@ACMRVOFF

 +2        XECUTE ACMLE

 +3        QUIT

 +4       ;

LIST       SET DIC="90022"_ACMDIC

           SET ACMDIC1="^ACM("_ACMDIC_")"

           SET ACMDIC2="^ACM("_ACMDIC_","

 +1        IF ACMDIC=41

               SET DA=ACMRGDFN

               DO LIST2

               QUIT

 +2        SET ACMA=""

 +3        FOR ACMI=0:0

               SET ACMA=$ORDER(@ACMDIC1@("AC",ACMRG,ACMPTNO,ACMA))

               IF ACMA=""

                   QUIT

               SET DA=^(ACMA)

               DO LIST2

 +4        SET ACMDICK="90022"_ACMDIC

 +5        KILL ^UTILITY("DIQ1",$JOB,ACMDICK),ACMA,ACMI,ACMDIC1

 +6        QUIT

 +7       ;

LIST2      SET ACMCNT=$LENGTH(ACMDIQF,";")

           SET DR=ACMDIQF

 +1        DO EN^DIQ1

 +2        SET ACMUTIL="^UTILITY(""DIQ1"""_","_$JOB_",90022"_ACMDIC_","_DA_")"

 +3        WRITE !

 +4        FOR ACMJ=1:1:ACMCNT

               SET ACMFLD=$PIECE(ACMDIQF,";",ACMJ)

               SET ACMPOS=$PIECE(ACMPOSS,";",ACMJ)

               Begin DoDot:1

 +5                SET G=$PIECE(ACMUTIL,")")_","_ACMFLD_",1)"

                   IF $DATA(@G)

                       DO WP

                       QUIT

 +6                SET ACMX=$SELECT($DATA(@ACMUTIL@(ACMFLD)):^(ACMFLD),1:"")

                   IF ACMX'=""

                       WRITE ?ACMPOS,ACMX

 +7                QUIT

               End DoDot:1

 +8        KILL ACMJ,ACMUTIL,ACMFLD,ACMPOS

 +9        QUIT

WP        ;Display of Word Processing Field

 +1        KILL ^UTILITY($JOB,"W")

 +2        SET ACMG=$PIECE(ACMUTIL,")")_","_ACMFLD_",ACMI)"

 +3        SET ACMI=0

FOR

               SET ACMI=$ORDER(@ACMG)

               IF ACMI=""

                   QUIT

               DO WP2

 +4        DO WPDISP

 +5        QUIT

 +6       ;

WP2       ;WP Length Format from 1-40 Characters rather than 80 standard

 +1       ;

 +2        SET DIWL=1

           SET DIWR=40

           SET X=@ACMG

           DO ^DIWP

 +3        QUIT

WPDISP    ;

 +1        SET Z=0

FOR

               SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))

               IF Z'=+Z

                   QUIT

               WRITE ?ACMPOS,^UTILITY($JOB,"W",DIWL,Z,0),!

 +2        KILL ^UTILITY($JOB,"W")

 +3        QUIT

ACMEP.m