APCDKUL ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
;;2.0;IHS PCC SUITE;**7,8,20**;MAY 14, 2009;Build 25
;
;IHS/CMI/LAB - added moving v file entries by ordering provider
;
;This routine can be run to move selected V File entries (by
;class of data) from one visit to another.
;ADD ALL OTHER V FILES????? IMM/SKIN PATCH 6
START ;EP
;
D GETPAT
I 'APCDPAT W !,$C(7),"No patient selected." D EOJ Q
D GETFROM
I 'APCDVMF W !,$C(7),"No from visit selected." D EOJ Q
S APCDVLDT=+^AUPNVSIT(APCDVMF,0)\1
D GETTO
I 'APCDVMT W !,$C(7),"No TO visit selected." D EOJ Q
I APCDVMT=APCDVMF W !,$C(7),"From and To visits are the same!",! D EOJ Q
;
EP1 ;EP
D GETVFILE
I '$D(APCDVFIL) W !,$C(7),"No V Files selected." D EOJ Q
D SURE
I $D(APCDQUIT) W !!,$C(7),"BYE" D EOJ Q
I '$P(APCDVFIL,";;",5) D ORDPROV ;maw
I $D(APCDQUIT) W !,"Bye" D EOJ Q
D ASK
I $D(APCDQUIT) W !,"Bye" D EOJ Q
D UNLINK
D EOJ
Q
;
EOJ ;
K X,Y,Z,DA,DIC,DIE,DR,DIU,A,%,B,DIV,DIW,DIY
K APCDVMF,APCDVMT,APCDVFIL,APCDJ,APCDTEXT,APCDQUIT,APCDVLDT,APCDPAT,APCDCAT,APCDCLN,APCDDATE,APCDLOC,APCDTYPE,APCDVMG,APCDVSIT,APCDZ,APCDASK
D KILL^AUPNPAT
K AUPNPAT,AUPNDAYS,AUPNDOD,AUPNDOB,AUPNSEX,AUPNVSIT
Q
GETPAT ; GET PATIENT
W !
S APCDPAT=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
Q:Y<0
S APCDPAT=+Y
Q
;
GETFROM ;
W !!,"Enter the visit that the ITEMS WILL BE REMOVED FROM",!
S APCDVMF=""
K APCDVLK
S APCDLOOK=""
D ^APCDVLK
S APCDVMF=APCDLOOK
K APCDLOOK
I APCDVMF S APCDVDSP=APCDVMF D ^APCDVDSP
Q
;
GETTO ;
W !!,"Enter the visit that the ITEMS WILL BE APPENDED TO",!
S APCDVMT=""
K APCDVLK
S APCDLOOK=""
D ^APCDVLK
S APCDVMT=APCDLOOK
K APCDLOOK
I APCDVMT S APCDVDSP=APCDVMT D ^APCDVDSP
Q
GETVFILE ;
W !!
K APCDVFIL
K APCDX,APCDJ,APCDTEXT
F APCDJ=1:1:18 S APCDX=$P($T(MENU+APCDJ),";;",2) W !?10,APCDJ,") ",APCDX
K APCDX,APCDJ,APCDTEXT
S DIR(0)="N^1:18:0",DIR("A")="Choose WHICH DATA ITEM TO MOVE",DIR("B")="18" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
Q:Y=18
S APCDVFIL=$P($T(MENU+Y),";;",2,99)
Q
SURE ;
S APCDVMG=^DIC($P(APCDVFIL,";;",4),0,"GL")
I '$D(@(APCDVMG_"""AD"","_APCDVMF_")")) W !!,$C(7),$C(7),"There are NO ",$P(APCDVFIL,";;",1)," to REPOINT!!",!! S APCDQUIT="" Q
W !!,"I will move the following from the FROM visit to the TO visit"
D DSPLY
K APCDQUIT
S DIR(0)="Y",DIR("A")="Are you sure you want to do this",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT)!('Y) S APCDQUIT="" Q
Q
ORDPROV ;
S APCDOP=""
S DIR(0)="Y",DIR("A")="Do you want to move the V Files entries for 1 ordering provider",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) S APCDQUIT=1 Q
I 'Y Q
;which ordering provider
S DIR(0)=APCDVFLE_",1202",DIR("A")="Which Ordering Provider" KILL DA D ^DIR KILL DIR
I $D(DIRUT) S APCDQUIT="" Q
I Y="" S APCDQUIT="" Q
S APCDOP=+Y
Q
ASK ;ask for each v file
K APCDQUIT
S APCDASK=""
S DIR(0)="Y",DIR("A")="Do you want to be asked before moving each V File entry",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) S APCDQUIT=1 Q
S APCDASK=Y
Q
UNLINK ;
K APCDVMQF,APCDVMUX
S U="^"
I '$D(APCDVMF)!('$D(APCDVMT)) S APCDVMQF=21 Q
I 'APCDVMF!('APCDVMT)!(APCDVMF=APCDVMT) S APCDVMQF=22 Q
I '$D(^AUPNVSIT(APCDVMF,0)) S APCDVMQF=23 Q
I '$D(^AUPNVSIT(APCDVMT,0)) S APCDVMQF=24 Q
I $P(^AUPNVSIT(APCDVMF,0),U,5)'=$P(^AUPNVSIT(APCDVMT,0),U,5) S APCDVMQF=25 Q
S APCDVMFL=$P(APCDVFIL,";;",4) D PROCESS
S AUPNVSIT=APCDVMT D MOD^AUPNVSIT
S AUPNVSIT=APCDVMF D MOD^AUPNVSIT
S APCDVDSP=APCDVMT D ^APCDVDSP
K APCDVMFL,APCDVMG,APCDVML,APCDVMN,APCDVMX,APCDVMUX
Q
;
;
DSPLY ;
S APCDVNM=$P(APCDVFIL,";;",2),APCDVDG=$P(APCDVFIL,";;",3),APCDVIGR=APCDVDG_"""AD"",APCDVMF,APCDVDFN)",APCDVDFN="",APCDVFLE=$P(APCDVFIL,";;",4)
F APCDVI=1:1 S APCDVDFN=$O(@APCDVIGR) Q:APCDVDFN="" D DSPLY3
Q
;
DSPLY3 ;
I APCDVI<2 S APCDX=20-$L($P(APCDVNM,"V ",2)_"'s"),APCDY=APCDX\2,APCDZ=APCDX-APCDY W !!,"==============",$J("",APCDZ),$P(APCDVNM,"V ",2)_"'s",$J("",APCDY),"=============="
I APCDVI>1 W !
K ^UTILITY("DIQ1",$J)
S DIC=APCDVDG,DR=".01;.04:99999",(DA,D0)=APCDVDFN D EN^DIQ1
D DSPLY4
Q
;
DSPLY4 ;
W !
F APCDY=0:0 S APCDY=$O(^UTILITY("DIQ1",$J,APCDVFLE,APCDVDFN,APCDY)) Q:'APCDY I ^UTILITY("DIQ1",$J,APCDVFLE,APCDVDFN,APCDY)]"" S APCDX=$P(^DD(APCDVFLE,APCDY,0),U)_": "_^UTILITY("DIQ1",$J,APCDVFLE,APCDVDFN,APCDY) D DSPLY41
K APCDT,APCDX,APCDY
Q
DSPLY41 ;
W:$X>39 ! S APCDT=$S($X<2:$X,1:$X+5) W:(APCDT+$L(APCDX))>79 ! S:(APCDT+$L(APCDX))>79 APCDT=0 W ?APCDT,APCDX
Q
WRITE ;
S APCDV=" "_APCDV_" "
S APCDX=APCDH_": "_APCDV W:$X>39 ! S APCDT=$S($X>1:41,1:1) W:(APCDT+$L(APCDX))>79 ! W ?APCDT,APCDH,": ",@APCDRVON,APCDV,@APCDRVOF
K APCDT,APCDX
Q
ASKCMV(TSE) ;maw ask to move if no op
K APCDQUIT
S APCDCMV=""
S DIR(0)="Y",DIR("A")="There is no ordering provider associated with "_TSE_", continue with move",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) S APCDQUIT=1 Q
S APCDCMV=Y
Q
PROCESS ; PROCESS ONE V FILE
S APCDVMUX=1
S APCDVMG=^DIC(APCDVMFL,0,"GL")
Q:'$D(@(APCDVMG_"""AD"","_APCDVMF_")"))
W:'$D(ZTQUEUED) !,APCDVMFL
S APCDVMN="" F APCDVML=0:0 S APCDVMN=$O(@(APCDVMG_"""AD"","_APCDVMF_",APCDVMN)")) Q:APCDVMN="" D PROCESS2
Q
PROCESS2 ; PROCESS ONE V FILE ENTRY
N X S X=APCDVMG_APCDVMN_",12)" S X=$G(@X)
I $G(APCDOP),$P(X,U,2)'=APCDOP Q
I 'APCDASK G DIK
W !!,"**********",!
K ^UTILITY("DIQ1",$J) S DIC=APCDVDG,DR="0;12",(DA,D0)=APCDVMN D EN^DIQ K ^UTILITY("DIQ1",$J)
W !
S DIR(0)="Y",DIR("A")="Do you want to Move this Entry",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
I 'Y Q
DIK ;
W:'$D(ZTQUEUED) "."
S DIK=APCDVMG,DA=APCDVMN,X=2 D DD^DIK,1^DIK1 K DIK,DA
S $P(@(APCDVMG_APCDVMN_",0)"),U,3)=APCDVMT
S DIK=APCDVMG,DA=APCDVMN,X=1 D DD^DIK,1^DIK1 K DIK,DA
Q
;;MEDICATIONS;;V MEDICATION;;^AUPNVMED(;;9000010.14
;;LAB TESTS;;V LAB;;^AUPNVLAB(;;9000010.09
;;DENTAL;;V DENTAL;;^AUPNVDEN(;;9000010.05
;;RADIOLOGY;;V RADIOLOGY;;^AUPNVRAD(;;9000010.22
;;MICROBIOLOGY;;V MICROBIOLOGY;;^AUPNVMIC(;;9000010.25
;;CPTS;;V CPT;;^AUPNVCPT(;;9000010.18
;;TRAN CODES;;V TRANSACTION CODES;;^AUPNVTC(;;9000010.33
;;MEDITECH CHARGES;;V TRANSACTION CHARGES (MEDITECH);;^AUPNVTRC(;;9000010.37
;;BLOOD BANK;;V BLOOD BANK;;^AUPNVBB(;;9000010.31
;;IMMUNIZATIONS;;V IMMUNIZATION;;^AUPNVIMM(;;9000010.11
;;SKIN TESTS;;V SKIN TEST;;^AUPNVSK(;;9000010.12
;;EXAMS;;V EXAM;;^AUPNVXAM(;;9000010.13
;;POVS;;V POV;;^AUPNVPOV(;;9000010.07;;1
;;VITALS (MEASUREMENTS);;V MEASUREMENT;;^AUPNVMSR(;;9000010.01;;1
;;PATIENT ED TOPICS;;V PATIENT ED;;^AUPNVPED(;;9000010.16;;1
;;PROCEDURES;;V PROCEDURE;;^AUPNVPRC(;;9000010.08
;;HEALTH FACTORS;;V HEALTH FACTOR;;^AUPNVHF(;;9000010.23;;1
;;NONE - QUIT
APCDKUL ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
+1 ;;2.0;IHS PCC SUITE;**7,8,20**;MAY 14, 2009;Build 25
+2 ;
+3 ;IHS/CMI/LAB - added moving v file entries by ordering provider
+4 ;
+5 ;This routine can be run to move selected V File entries (by
+6 ;class of data) from one visit to another.
+7 ;ADD ALL OTHER V FILES????? IMM/SKIN PATCH 6
START ;EP
+1 ;
+2 DO GETPAT
+3 IF 'APCDPAT
WRITE !,$CHAR(7),"No patient selected."
DO EOJ
QUIT
+4 DO GETFROM
+5 IF 'APCDVMF
WRITE !,$CHAR(7),"No from visit selected."
DO EOJ
QUIT
+6 SET APCDVLDT=+^AUPNVSIT(APCDVMF,0)\1
+7 DO GETTO
+8 IF 'APCDVMT
WRITE !,$CHAR(7),"No TO visit selected."
DO EOJ
QUIT
+9 IF APCDVMT=APCDVMF
WRITE !,$CHAR(7),"From and To visits are the same!",!
DO EOJ
QUIT
+10 ;
EP1 ;EP
+1 DO GETVFILE
+2 IF '$DATA(APCDVFIL)
WRITE !,$CHAR(7),"No V Files selected."
DO EOJ
QUIT
+3 DO SURE
+4 IF $DATA(APCDQUIT)
WRITE !!,$CHAR(7),"BYE"
DO EOJ
QUIT
+5 ;maw
IF '$PIECE(APCDVFIL,";;",5)
DO ORDPROV
+6 IF $DATA(APCDQUIT)
WRITE !,"Bye"
DO EOJ
QUIT
+7 DO ASK
+8 IF $DATA(APCDQUIT)
WRITE !,"Bye"
DO EOJ
QUIT
+9 DO UNLINK
+10 DO EOJ
+11 QUIT
+12 ;
EOJ ;
+1 KILL X,Y,Z,DA,DIC,DIE,DR,DIU,A,%,B,DIV,DIW,DIY
+2 KILL APCDVMF,APCDVMT,APCDVFIL,APCDJ,APCDTEXT,APCDQUIT,APCDVLDT,APCDPAT,APCDCAT,APCDCLN,APCDDATE,APCDLOC,APCDTYPE,APCDVMG,APCDVSIT,APCDZ,APCDASK
+3 DO KILL^AUPNPAT
+4 KILL AUPNPAT,AUPNDAYS,AUPNDOD,AUPNDOB,AUPNSEX,AUPNVSIT
+5 QUIT
GETPAT ; GET PATIENT
+1 WRITE !
+2 SET APCDPAT=""
+3 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+4 IF Y<0
QUIT
+5 SET APCDPAT=+Y
+6 QUIT
+7 ;
GETFROM ;
+1 WRITE !!,"Enter the visit that the ITEMS WILL BE REMOVED FROM",!
+2 SET APCDVMF=""
+3 KILL APCDVLK
+4 SET APCDLOOK=""
+5 DO ^APCDVLK
+6 SET APCDVMF=APCDLOOK
+7 KILL APCDLOOK
+8 IF APCDVMF
SET APCDVDSP=APCDVMF
DO ^APCDVDSP
+9 QUIT
+10 ;
GETTO ;
+1 WRITE !!,"Enter the visit that the ITEMS WILL BE APPENDED TO",!
+2 SET APCDVMT=""
+3 KILL APCDVLK
+4 SET APCDLOOK=""
+5 DO ^APCDVLK
+6 SET APCDVMT=APCDLOOK
+7 KILL APCDLOOK
+8 IF APCDVMT
SET APCDVDSP=APCDVMT
DO ^APCDVDSP
+9 QUIT
GETVFILE ;
+1 WRITE !!
+2 KILL APCDVFIL
+3 KILL APCDX,APCDJ,APCDTEXT
+4 FOR APCDJ=1:1:18
SET APCDX=$PIECE($TEXT(MENU+APCDJ),";;",2)
WRITE !?10,APCDJ,") ",APCDX
+5 KILL APCDX,APCDJ,APCDTEXT
+6 SET DIR(0)="N^1:18:0"
SET DIR("A")="Choose WHICH DATA ITEM TO MOVE"
SET DIR("B")="18"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+7 IF $DATA(DIRUT)
QUIT
+8 IF Y=18
QUIT
+9 SET APCDVFIL=$PIECE($TEXT(MENU+Y),";;",2,99)
+10 QUIT
SURE ;
+1 SET APCDVMG=^DIC($PIECE(APCDVFIL,";;",4),0,"GL")
+2 IF '$DATA(@(APCDVMG_"""AD"","_APCDVMF_")"))
WRITE !!,$CHAR(7),$CHAR(7),"There are NO ",$PIECE(APCDVFIL,";;",1)," to REPOINT!!",!!
SET APCDQUIT=""
QUIT
+3 WRITE !!,"I will move the following from the FROM visit to the TO visit"
+4 DO DSPLY
+5 KILL APCDQUIT
+6 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to do this"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+7 IF $DATA(DIRUT)!('Y)
SET APCDQUIT=""
QUIT
+8 QUIT
ORDPROV ;
+1 SET APCDOP=""
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to move the V Files entries for 1 ordering provider"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
SET APCDQUIT=1
QUIT
+4 IF 'Y
QUIT
+5 ;which ordering provider
+6 SET DIR(0)=APCDVFLE_",1202"
SET DIR("A")="Which Ordering Provider"
KILL DA
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
SET APCDQUIT=""
QUIT
+8 IF Y=""
SET APCDQUIT=""
QUIT
+9 SET APCDOP=+Y
+10 QUIT
ASK ;ask for each v file
+1 KILL APCDQUIT
+2 SET APCDASK=""
+3 SET DIR(0)="Y"
SET DIR("A")="Do you want to be asked before moving each V File entry"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
SET APCDQUIT=1
QUIT
+5 SET APCDASK=Y
+6 QUIT
UNLINK ;
+1 KILL APCDVMQF,APCDVMUX
+2 SET U="^"
+3 IF '$DATA(APCDVMF)!('$DATA(APCDVMT))
SET APCDVMQF=21
QUIT
+4 IF 'APCDVMF!('APCDVMT)!(APCDVMF=APCDVMT)
SET APCDVMQF=22
QUIT
+5 IF '$DATA(^AUPNVSIT(APCDVMF,0))
SET APCDVMQF=23
QUIT
+6 IF '$DATA(^AUPNVSIT(APCDVMT,0))
SET APCDVMQF=24
QUIT
+7 IF $PIECE(^AUPNVSIT(APCDVMF,0),U,5)'=$PIECE(^AUPNVSIT(APCDVMT,0),U,5)
SET APCDVMQF=25
QUIT
+8 SET APCDVMFL=$PIECE(APCDVFIL,";;",4)
DO PROCESS
+9 SET AUPNVSIT=APCDVMT
DO MOD^AUPNVSIT
+10 SET AUPNVSIT=APCDVMF
DO MOD^AUPNVSIT
+11 SET APCDVDSP=APCDVMT
DO ^APCDVDSP
+12 KILL APCDVMFL,APCDVMG,APCDVML,APCDVMN,APCDVMX,APCDVMUX
+13 QUIT
+14 ;
+15 ;
DSPLY ;
+1 SET APCDVNM=$PIECE(APCDVFIL,";;",2)
SET APCDVDG=$PIECE(APCDVFIL,";;",3)
SET APCDVIGR=APCDVDG_"""AD"",APCDVMF,APCDVDFN)"
SET APCDVDFN=""
SET APCDVFLE=$PIECE(APCDVFIL,";;",4)
+2 FOR APCDVI=1:1
SET APCDVDFN=$ORDER(@APCDVIGR)
IF APCDVDFN=""
QUIT
DO DSPLY3
+3 QUIT
+4 ;
DSPLY3 ;
+1 IF APCDVI<2
SET APCDX=20-$LENGTH($PIECE(APCDVNM,"V ",2)_"'s")
SET APCDY=APCDX\2
SET APCDZ=APCDX-APCDY
WRITE !!,"==============",$JUSTIFY("",APCDZ),$PIECE(APCDVNM,"V ",2)_"'s",$JUSTIFY("",APCDY),"=============="
+2 IF APCDVI>1
WRITE !
+3 KILL ^UTILITY("DIQ1",$JOB)
+4 SET DIC=APCDVDG
SET DR=".01;.04:99999"
SET (DA,D0)=APCDVDFN
DO EN^DIQ1
+5 DO DSPLY4
+6 QUIT
+7 ;
DSPLY4 ;
+1 WRITE !
+2 FOR APCDY=0:0
SET APCDY=$ORDER(^UTILITY("DIQ1",$JOB,APCDVFLE,APCDVDFN,APCDY))
IF 'APCDY
QUIT
IF ^UTILITY("DIQ1",$JOB,APCDVFLE,APCDVDFN,APCDY)]""
SET APCDX=$PIECE(^DD(APCDVFLE,APCDY,0),U)_": "_^UTILITY("DIQ1",$JOB,APCDVFLE,APCDVDFN,APCDY)
DO DSPLY41
+3 KILL APCDT,APCDX,APCDY
+4 QUIT
DSPLY41 ;
+1 IF $X>39
WRITE !
SET APCDT=$SELECT($X<2:$X,1:$X+5)
IF (APCDT+$LENGTH(APCDX))>79
WRITE !
IF (APCDT+$LENGTH(APCDX))>79
SET APCDT=0
WRITE ?APCDT,APCDX
+2 QUIT
WRITE ;
+1 SET APCDV=" "_APCDV_" "
+2 SET APCDX=APCDH_": "_APCDV
IF $X>39
WRITE !
SET APCDT=$SELECT($X>1:41,1:1)
IF (APCDT+$LENGTH(APCDX))>79
WRITE !
WRITE ?APCDT,APCDH,": ",@APCDRVON,APCDV,@APCDRVOF
+3 KILL APCDT,APCDX
+4 QUIT
ASKCMV(TSE) ;maw ask to move if no op
+1 KILL APCDQUIT
+2 SET APCDCMV=""
+3 SET DIR(0)="Y"
SET DIR("A")="There is no ordering provider associated with "_TSE_", continue with move"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
SET APCDQUIT=1
QUIT
+5 SET APCDCMV=Y
+6 QUIT
PROCESS ; PROCESS ONE V FILE
+1 SET APCDVMUX=1
+2 SET APCDVMG=^DIC(APCDVMFL,0,"GL")
+3 IF '$DATA(@(APCDVMG_"""AD"","_APCDVMF_")"))
QUIT
+4 IF '$DATA(ZTQUEUED)
WRITE !,APCDVMFL
+5 SET APCDVMN=""
FOR APCDVML=0:0
SET APCDVMN=$ORDER(@(APCDVMG_"""AD"","_APCDVMF_",APCDVMN)"))
IF APCDVMN=""
QUIT
DO PROCESS2
+6 QUIT
PROCESS2 ; PROCESS ONE V FILE ENTRY
+1 NEW X
SET X=APCDVMG_APCDVMN_",12)"
SET X=$GET(@X)
+2 IF $GET(APCDOP)
IF $PIECE(X,U,2)'=APCDOP
QUIT
+3 IF 'APCDASK
GOTO DIK
+4 WRITE !!,"**********",!
+5 KILL ^UTILITY("DIQ1",$JOB)
SET DIC=APCDVDG
SET DR="0;12"
SET (DA,D0)=APCDVMN
DO EN^DIQ
KILL ^UTILITY("DIQ1",$JOB)
+6 WRITE !
+7 SET DIR(0)="Y"
SET DIR("A")="Do you want to Move this Entry"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
QUIT
+9 IF 'Y
QUIT
DIK ;
+1 IF '$DATA(ZTQUEUED)
WRITE "."
+2 SET DIK=APCDVMG
SET DA=APCDVMN
SET X=2
DO DD^DIK
DO 1^DIK1
KILL DIK,DA
+3 SET $PIECE(@(APCDVMG_APCDVMN_",0)"),U,3)=APCDVMT
+4 SET DIK=APCDVMG
SET DA=APCDVMN
SET X=1
DO DD^DIK
DO 1^DIK1
KILL DIK,DA
+5 QUIT
+1 ;;MEDICATIONS;;V MEDICATION;;^AUPNVMED(;;9000010.14
+2 ;;LAB TESTS;;V LAB;;^AUPNVLAB(;;9000010.09
+3 ;;DENTAL;;V DENTAL;;^AUPNVDEN(;;9000010.05
+4 ;;RADIOLOGY;;V RADIOLOGY;;^AUPNVRAD(;;9000010.22
+5 ;;MICROBIOLOGY;;V MICROBIOLOGY;;^AUPNVMIC(;;9000010.25
+6 ;;CPTS;;V CPT;;^AUPNVCPT(;;9000010.18
+7 ;;TRAN CODES;;V TRANSACTION CODES;;^AUPNVTC(;;9000010.33
+8 ;;MEDITECH CHARGES;;V TRANSACTION CHARGES (MEDITECH);;^AUPNVTRC(;;9000010.37
+9 ;;BLOOD BANK;;V BLOOD BANK;;^AUPNVBB(;;9000010.31
+10 ;;IMMUNIZATIONS;;V IMMUNIZATION;;^AUPNVIMM(;;9000010.11
+11 ;;SKIN TESTS;;V SKIN TEST;;^AUPNVSK(;;9000010.12
+12 ;;EXAMS;;V EXAM;;^AUPNVXAM(;;9000010.13
+13 ;;POVS;;V POV;;^AUPNVPOV(;;9000010.07;;1
+14 ;;VITALS (MEASUREMENTS);;V MEASUREMENT;;^AUPNVMSR(;;9000010.01;;1
+15 ;;PATIENT ED TOPICS;;V PATIENT ED;;^AUPNVPED(;;9000010.16;;1
+16 ;;PROCEDURES;;V PROCEDURE;;^AUPNVPRC(;;9000010.08
+17 ;;HEALTH FACTORS;;V HEALTH FACTOR;;^AUPNVHF(;;9000010.23;;1
+18 ;;NONE - QUIT
