APCD20P4.m

APCD20P4 ; IHS/CMI/TUCSON - DATA ENTRY PATCH 4 [ 03/27/01  8:55 AM ]

 ;;2.0;IHS RPMS/PCC Data Entry;**4**;MAR 09, 1999

 ;

 ; The following line prevents the "Disable Options..." and "Move

 ; Routines..." questions from being asked during the install.

 I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 ;

 Q

 ;

POST ;

P4P ;patch 4 post init

 NEW APCDT,APCDJ,APCDX,APCDM,APCD17,APCD18

 ;populate cohort list entry in all mnemonics

 S APCDT="CLO" F APCDJ=1:1 S APCDX=$T(@APCDT+APCDJ) Q:APCDX=""  D

 .S APCDM=$P(APCDX,";;",2),APCD17=$P(APCDX,";;",3),APCD18=$P(APCDX,";;",4)

 .S DA=$O(^APCDTKW("B",APCDM,0))

 .I 'DA W !,"Could not find mnemonic ",APCDM," to update." H 3 Q

 .S DIE="^APCDTKW(",DR=".17///"_APCD17_";.18///"_APCD18 D ^DIE

 .I $D(Y) W !,"Failure updating mnemonic ",APCDM,"." H 3 Q

 .K DIE,DA,DR,DIU,DIV,DIW,Y,X

 .Q

 D OVR

 D HFOB

 D HSIG

 D HBE

 D HCOL

 D ECO2

 D ECO3

 D TRC

 D UNH

 D ^APC4INIT

 NEW X

 S X=$$ADD^XPDMENU("APCD MENU ENTER DATA","APCDECOHORT ENTRY","EC",82)

 I 'X W "Attempt to add COHORT Data Entry option failed." H 3

 D ^APCDBUL4

 Q

HFOB ;

 D ^XBFMK

 Q:$D(^APCDTKW("B","HFOB"))

 S X="HFOB",DIC(0)="L",DIC="^APCDTKW(",DIC("DR")=".03///9000001;.04///[APCD HFOB];.06///Historical FOBT (GUAIAC);.07///0;.08///0;.09///9000010.18;.12///Historical FOBT;.15///31;.16///31"

 K DD,D0,DO

 D FILE^DICN

 I Y=-1 W !!,"Adding HFOB mnemonic failed." H 4

 K DIC,DD,D0,DO

 Q

HBE ;

 D ^XBFMK

 Q:$D(^APCDTKW("B","HBE"))

 S X="HBE",DIC(0)="L",DIC="^APCDTKW(",DIC("DR")=".03///9000001;.04///[APCD HBE];.06///Historical Barium Enema;.07///0;.08///0;.09///9000010.18;.12///Historical BE;.15///33;.16///33"

 K DD,D0,DO

 D FILE^DICN

 I Y=-1 W !!,"Adding HBE mnemonic failed." H 4

 K DIC,DD,D0,DO

 Q

HCOL ;

 D ^XBFMK

 Q:$D(^APCDTKW("B","HCOL"))

 S X="HCOL",DIC(0)="L",DIC="^APCDTKW(",DIC("DR")=".03///9000001;.04///[APCD HCOL];.06///Historical Colonoscopy;.07///0;.08///0;.09///9000010.18;.12///Hist. Colonoscopy;.15///34;.16///34"

 K DD,D0,DO

 D FILE^DICN

 I Y=-1 W !!,"Adding HCOL mnemonic failed." H 4

 K DIC,DD,D0,DO

 Q

HSIG ;

 D ^XBFMK

 Q:$D(^APCDTKW("B","HSIG"))

 S X="HSIG",DIC(0)="L",DIC="^APCDTKW(",DIC("DR")=".03///9000001;.04///[APCD HSIG];.06///Historical Sigmoidoscopy;.07///0;.08///0;.09///9000010.18;.12///Hist. Sigmoidoscopy;.15///32;.16///32"

 K DD,D0,DO

 D FILE^DICN

 I Y=-1 W !!,"Adding HSIG mnemonic failed." H 4

 K DIC,DD,D0,DO

 Q

OVR ;

 D ^XBFMK

 Q:$D(^APCDTKW("B","OVR"))

 S X="OVR",DIC(0)="L",DIC="^APCDTKW(",DIC("DR")=".03///9000001;.04///[APCD OVR];.06///Health Reminder Override;.07///0;.08///0;.09///9000025"

 K DD,D0,DO

 D FILE^DICN

 I Y=-1 W !!,"Adding OVR mnemonic failed." H 4

 K DIC,DD,D0,DO

 Q

CPE ;

 D ^XBFMK

 Q:$D(^APCDTKW("B","3MCPE"))

 S X="3MCPE",DIC(0)="L",DIC="^APCDTKW(",DIC("DR")=".03///9000010;.04///[APCD 3MCPE];.06///CPE Mnemonic to File 3m CPT;.07///0;.08///1"

 K DD,D0,DO

 D FILE^DICN

 I Y=-1 W !!,"Adding 3MCPE mnemonic failed." H 4

 K DIC,DD,D0,DO

 Q

UNH ;

 D ^XBFMK

 Q:$D(^APCDTKW("B","UNH"))

 S X="UNH",DIC(0)="L",DIC="^APCDTKW(",DIC("DR")=".03///9000010;.04///[APCD UNH];.06///Auditory Evoked Potential Exam;.07///0;.08///1;.09///9000010.38;.12///Auditory Evoked Exam;.13///22;.14///9000010.38"

 K DD,D0,DO

 D FILE^DICN

 I Y=-1 W !!,"Adding UNH mnemonic failed." H 4

 K DIC,DD,D0,DO

 Q

TRC ;

 D ^XBFMK

 Q:$D(^APCDTKW("B","TRC"))

 S X="TRC",DIC(0)="L",DIC="^APCDTKW(",DIC("DR")=".03///9000010;.04///[APCD TRC];.06///Treatment Contracts;.07///0;.08///1;.09///9000010.39"

 K DD,D0,DO

 D FILE^DICN

 I Y=-1 W !!,"Adding TRC mnemonic failed." H 4

 K DIC,DD,D0,DO

 Q

ECO2 ;chief complaint mnemonic

 D ^XBFMK

 Q:$D(^APCDTKW("B","ECO2"))

 S X="ECO2",DIC(0)="L",DIC="^APCDTKW(",DIC("DR")=".02///S;.03///9000010;.04///[APCD ECO2];.06///Append a 2nd E-Code to a POV;.07///0;.08///1"

 K DD,D0,DO

 D FILE^DICN

 I Y=-1 W !!,"Adding ECO2 mnemonic failed." H 4

 K DIC,DD,D0,DO

 Q

 ;

ECO3 ;

 D ^XBFMK

 Q:$D(^APCDTKW("B","ECO3"))

 S X="ECO3",DIC(0)="L",DIC="^APCDTKW(",DIC("DR")=".02///S;.03///9000010;.04///[APCD ECO3];.06///Append a 3rd E-Code to a POV;.07///0;.08///1"

 K DD,D0,DO

 D FILE^DICN

 I Y=-1 W !!,"Adding ECO3 mnemonic failed." H 4

 K DIC,DD,D0,DO

 Q

 ;

CLO ;

 ;;AG;;;;5.0

 ;;AL;;;;65.0

 ;;APPT;;;;70.0

 ;;AT;;160.0;;

 ;;AUD;;;;40.0

 ;;BM;;;;62.0

 ;;BP;;15.0;;

 ;;BS;;115.0;;

 ;;BT;;;;85.0

 ;;CBC;;120.0

 ;;CC;;;;90.0

 ;;CHT;;;;45.0

 ;;CKO;;;;75.0

 ;;CPT;;75.0

 ;;CXD;;;;10.0

 ;;DC;;;;95.0

 ;;ED;;;;15.0

 ;;EDC;;197.0

 ;;EFF;;;;20.0

 ;;EKG;;155.0

 ;;EL;;175.0

 ;;EM;;65.0

 ;;ER;;170.0

 ;;EX;;78.0

 ;;FHX;;;;100.0

 ;;FM;;190.0

 ;;FP;;195.0

 ;;FT;;;;25.0

 ;;GP;;;;110.0

 ;;GWT;;;;50.0

 ;;HC;;30.0

 ;;HCT;;105.0

 ;;HE;;35.0

 ;;HF;;145.0

 ;;HT;;20.0

 ;;IM;;80.0

 ;;KWT;;;;55.0

 ;;LAB;;95.0

 ;;LMP;;185.0

 ;;NMI;;;;125.0

 ;;NRF;;;;130.0

 ;;OP;;70.0

 ;;PAP;;110.0

 ;;PCP;;;;96.0

 ;;PED;;140.0

 ;;PHN;;165.0

 ;;PHX;;;;105.0

 ;;PR;;;;30.0

 ;;PRV;;5.0

 ;;PRX;;125.0

 ;;PT;;130.0

 ;;PU;;55.0

 ;;PV;;10.0

 ;;RAD;;150.0

 ;;REF;;;;120.0

 ;;RF;;180.0

 ;;RS;;60.0

 ;;ST;;85.0

 ;;STG;;;;115.0

 ;;STN;;;;35.0

 ;;STP;;90.0

 ;;TA;;;;76.0

 ;;TD;;;;80.0

 ;;TMP;;50.0

 ;;TON;;;;60.0

 ;;TP;;135.00

 ;;UA;;100.0

 ;;VC;;45.0

 ;;VU;;40.0

 ;;WT;;25.0

APCD20P4  ; IHS/CMI/TUCSON - DATA ENTRY PATCH 4 [ 03/27/01  8:55 AM ]

 +1       ;;2.0;IHS RPMS/PCC Data Entry;**4**;MAR 09, 1999

 +2       ;

 +3       ; The following line prevents the "Disable Options..." and "Move

 +4       ; Routines..." questions from being asked during the install.

 +5        IF $GET(XPDENV)=1

               SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 +6       ;

 +7        QUIT 

 +8       ;

POST      ;

P4P       ;patch 4 post init

 +1        NEW APCDT,APCDJ,APCDX,APCDM,APCD17,APCD18

 +2       ;populate cohort list entry in all mnemonics

 +3        SET APCDT="CLO"

           FOR APCDJ=1:1

               SET APCDX=$TEXT(@APCDT+APCDJ)

               IF APCDX=""

                   QUIT 

               Begin DoDot:1

 +4                SET APCDM=$PIECE(APCDX,";;",2)

                   SET APCD17=$PIECE(APCDX,";;",3)

                   SET APCD18=$PIECE(APCDX,";;",4)

 +5                SET DA=$ORDER(^APCDTKW("B",APCDM,0))

 +6                IF 'DA

                       WRITE !,"Could not find mnemonic ",APCDM," to update."

                       HANG 3

                       QUIT 

 +7                SET DIE="^APCDTKW("

                   SET DR=".17///"_APCD17_";.18///"_APCD18

                   DO ^DIE

 +8                IF $DATA(Y)

                       WRITE !,"Failure updating mnemonic ",APCDM,"."

                       HANG 3

                       QUIT 

 +9                KILL DIE,DA,DR,DIU,DIV,DIW,Y,X

 +10               QUIT 

               End DoDot:1

 +11       DO OVR

 +12       DO HFOB

 +13       DO HSIG

 +14       DO HBE

 +15       DO HCOL

 +16       DO ECO2

 +17       DO ECO3

 +18       DO TRC

 +19       DO UNH

 +20       DO ^APC4INIT

 +21       NEW X

 +22       SET X=$$ADD^XPDMENU("APCD MENU ENTER DATA","APCDECOHORT ENTRY","EC",82)

 +23       IF 'X

               WRITE "Attempt to add COHORT Data Entry option failed."

               HANG 3

 +24       DO ^APCDBUL4

 +25       QUIT 

HFOB      ;

 +1        DO ^XBFMK

 +2        IF $DATA(^APCDTKW("B","HFOB"))

               QUIT 

 +3        SET X="HFOB"

           SET DIC(0)="L"

           SET DIC="^APCDTKW("

           SET DIC("DR")=".03///9000001;.04///[APCD HFOB];.06///Historical FOBT (GUAIAC);.07///0;.08///0;.09///9000010.18;.12///Historical FOBT;.15///31;.16///31"

 +4        KILL DD,D0,DO

 +5        DO FILE^DICN

 +6        IF Y=-1

               WRITE !!,"Adding HFOB mnemonic failed."

               HANG 4

 +7        KILL DIC,DD,D0,DO

 +8        QUIT 

HBE       ;

 +1        DO ^XBFMK

 +2        IF $DATA(^APCDTKW("B","HBE"))

               QUIT 

 +3        SET X="HBE"

           SET DIC(0)="L"

           SET DIC="^APCDTKW("

           SET DIC("DR")=".03///9000001;.04///[APCD HBE];.06///Historical Barium Enema;.07///0;.08///0;.09///9000010.18;.12///Historical BE;.15///33;.16///33"

 +4        KILL DD,D0,DO

 +5        DO FILE^DICN

 +6        IF Y=-1

               WRITE !!,"Adding HBE mnemonic failed."

               HANG 4

 +7        KILL DIC,DD,D0,DO

 +8        QUIT 

HCOL      ;

 +1        DO ^XBFMK

 +2        IF $DATA(^APCDTKW("B","HCOL"))

               QUIT 

 +3        SET X="HCOL"

           SET DIC(0)="L"

           SET DIC="^APCDTKW("

           SET DIC("DR")=".03///9000001;.04///[APCD HCOL];.06///Historical Colonoscopy;.07///0;.08///0;.09///9000010.18;.12///Hist. Colonoscopy;.15///34;.16///34"

 +4        KILL DD,D0,DO

 +5        DO FILE^DICN

 +6        IF Y=-1

               WRITE !!,"Adding HCOL mnemonic failed."

               HANG 4

 +7        KILL DIC,DD,D0,DO

 +8        QUIT 

HSIG      ;

 +1        DO ^XBFMK

 +2        IF $DATA(^APCDTKW("B","HSIG"))

               QUIT 

 +3        SET X="HSIG"

           SET DIC(0)="L"

           SET DIC="^APCDTKW("

           SET DIC("DR")=".03///9000001;.04///[APCD HSIG];.06///Historical Sigmoidoscopy;.07///0;.08///0;.09///9000010.18;.12///Hist. Sigmoidoscopy;.15///32;.16///32"

 +4        KILL DD,D0,DO

 +5        DO FILE^DICN

 +6        IF Y=-1

               WRITE !!,"Adding HSIG mnemonic failed."

               HANG 4

 +7        KILL DIC,DD,D0,DO

 +8        QUIT 

OVR       ;

 +1        DO ^XBFMK

 +2        IF $DATA(^APCDTKW("B","OVR"))

               QUIT 

 +3        SET X="OVR"

           SET DIC(0)="L"

           SET DIC="^APCDTKW("

           SET DIC("DR")=".03///9000001;.04///[APCD OVR];.06///Health Reminder Override;.07///0;.08///0;.09///9000025"

 +4        KILL DD,D0,DO

 +5        DO FILE^DICN

 +6        IF Y=-1

               WRITE !!,"Adding OVR mnemonic failed."

               HANG 4

 +7        KILL DIC,DD,D0,DO

 +8        QUIT 

CPE       ;

 +1        DO ^XBFMK

 +2        IF $DATA(^APCDTKW("B","3MCPE"))

               QUIT 

 +3        SET X="3MCPE"

           SET DIC(0)="L"

           SET DIC="^APCDTKW("

           SET DIC("DR")=".03///9000010;.04///[APCD 3MCPE];.06///CPE Mnemonic to File 3m CPT;.07///0;.08///1"

 +4        KILL DD,D0,DO

 +5        DO FILE^DICN

 +6        IF Y=-1

               WRITE !!,"Adding 3MCPE mnemonic failed."

               HANG 4

 +7        KILL DIC,DD,D0,DO

 +8        QUIT 

UNH       ;

 +1        DO ^XBFMK

 +2        IF $DATA(^APCDTKW("B","UNH"))

               QUIT 

 +3        SET X="UNH"

           SET DIC(0)="L"

           SET DIC="^APCDTKW("

           SET DIC("DR")=".03///9000010;.04///[APCD UNH];.06///Auditory Evoked Potential Exam;.07///0;.08///1;.09///9000010.38;.12///Auditory Evoked Exam;.13///22;.14///9000010.38"

 +4        KILL DD,D0,DO

 +5        DO FILE^DICN

 +6        IF Y=-1

               WRITE !!,"Adding UNH mnemonic failed."

               HANG 4

 +7        KILL DIC,DD,D0,DO

 +8        QUIT 

TRC       ;

 +1        DO ^XBFMK

 +2        IF $DATA(^APCDTKW("B","TRC"))

               QUIT 

 +3        SET X="TRC"

           SET DIC(0)="L"

           SET DIC="^APCDTKW("

           SET DIC("DR")=".03///9000010;.04///[APCD TRC];.06///Treatment Contracts;.07///0;.08///1;.09///9000010.39"

 +4        KILL DD,D0,DO

 +5        DO FILE^DICN

 +6        IF Y=-1

               WRITE !!,"Adding TRC mnemonic failed."

               HANG 4

 +7        KILL DIC,DD,D0,DO

 +8        QUIT 

ECO2      ;chief complaint mnemonic

 +1        DO ^XBFMK

 +2        IF $DATA(^APCDTKW("B","ECO2"))

               QUIT 

 +3        SET X="ECO2"

           SET DIC(0)="L"

           SET DIC="^APCDTKW("

           SET DIC("DR")=".02///S;.03///9000010;.04///[APCD ECO2];.06///Append a 2nd E-Code to a POV;.07///0;.08///1"

 +4        KILL DD,D0,DO

 +5        DO FILE^DICN

 +6        IF Y=-1

               WRITE !!,"Adding ECO2 mnemonic failed."

               HANG 4

 +7        KILL DIC,DD,D0,DO

 +8        QUIT 

 +9       ;

ECO3      ;

 +1        DO ^XBFMK

 +2        IF $DATA(^APCDTKW("B","ECO3"))

               QUIT 

 +3        SET X="ECO3"

           SET DIC(0)="L"

           SET DIC="^APCDTKW("

           SET DIC("DR")=".02///S;.03///9000010;.04///[APCD ECO3];.06///Append a 3rd E-Code to a POV;.07///0;.08///1"

 +4        KILL DD,D0,DO

 +5        DO FILE^DICN

 +6        IF Y=-1

               WRITE !!,"Adding ECO3 mnemonic failed."

               HANG 4

 +7        KILL DIC,DD,D0,DO

 +8        QUIT 

 +9       ;

CLO       ;

 +1       ;;AG;;;;5.0

 +2       ;;AL;;;;65.0

 +3       ;;APPT;;;;70.0

 +4       ;;AT;;160.0;;

 +5       ;;AUD;;;;40.0

 +6       ;;BM;;;;62.0

 +7       ;;BP;;15.0;;

 +8       ;;BS;;115.0;;

 +9       ;;BT;;;;85.0

 +10      ;;CBC;;120.0

 +11      ;;CC;;;;90.0

 +12      ;;CHT;;;;45.0

 +13      ;;CKO;;;;75.0

 +14      ;;CPT;;75.0

 +15      ;;CXD;;;;10.0

 +16      ;;DC;;;;95.0

 +17      ;;ED;;;;15.0

 +18      ;;EDC;;197.0

 +19      ;;EFF;;;;20.0

 +20      ;;EKG;;155.0

 +21      ;;EL;;175.0

 +22      ;;EM;;65.0

 +23      ;;ER;;170.0

 +24      ;;EX;;78.0

 +25      ;;FHX;;;;100.0

 +26      ;;FM;;190.0

 +27      ;;FP;;195.0

 +28      ;;FT;;;;25.0

 +29      ;;GP;;;;110.0

 +30      ;;GWT;;;;50.0

 +31      ;;HC;;30.0

 +32      ;;HCT;;105.0

 +33      ;;HE;;35.0

 +34      ;;HF;;145.0

 +35      ;;HT;;20.0

 +36      ;;IM;;80.0

 +37      ;;KWT;;;;55.0

 +38      ;;LAB;;95.0

 +39      ;;LMP;;185.0

 +40      ;;NMI;;;;125.0

 +41      ;;NRF;;;;130.0

 +42      ;;OP;;70.0

 +43      ;;PAP;;110.0

 +44      ;;PCP;;;;96.0

 +45      ;;PED;;140.0

 +46      ;;PHN;;165.0

 +47      ;;PHX;;;;105.0

 +48      ;;PR;;;;30.0

 +49      ;;PRV;;5.0

 +50      ;;PRX;;125.0

 +51      ;;PT;;130.0

 +52      ;;PU;;55.0

 +53      ;;PV;;10.0

 +54      ;;RAD;;150.0

 +55      ;;REF;;;;120.0

 +56      ;;RF;;180.0

 +57      ;;RS;;60.0

 +58      ;;ST;;85.0

 +59      ;;STG;;;;115.0

 +60      ;;STN;;;;35.0

 +61      ;;STP;;90.0

 +62      ;;TA;;;;76.0

 +63      ;;TD;;;;80.0

 +64      ;;TMP;;50.0

 +65      ;;TON;;;;60.0

 +66      ;;TP;;135.00

 +67      ;;UA;;100.0

 +68      ;;VC;;45.0

 +69      ;;VU;;40.0

 +70      ;;WT;;25.0