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
