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

APCDKUL.m

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