Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCDKULD

APCDKULD.m

Go to the documentation of this file.
APCDKULD ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ; 28 Jul 2017  10:40 AM
 ;;2.0;IHS PCC SUITE;**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
 ;D ORDPROV
 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 ;EP
 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 ;EP
 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
 K APCDVMQF
 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
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