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

ACD4P1PB.m

Go to the documentation of this file. 
  1. ACD4P1PB ;IHS/ADC/EDE/KML - BROKE UP ACD4P1P;
  1.  ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
  1.  ;; 01-26-98
  1.  ;; 01-26-98
  1.  ;
  1.  ; This routine converts file 6 pointers to file 200 pointers.
  1.  ;
  1. CHGACDF ; CHANGE CDMIS FIELDS  
  1.  I $D(^ACDCNV("B","1")) D  S ACDQ=1 Q  ;   quit if conversion done
  1.  .  W !,"File 6 to file 200 conversion already done.",!
  1.  .  Q
  1.  W !,"I am now going to repoint your CDMIS provider pointers to point",!,"  to the NEW PERSON file. Please wait.",!
  1.  D CHG70P7 ;          change file 9002170.7 (CDMIS PREVENTION)
  1.  D CHG72 ;            change file 9002172 (CDMIS CLIENT SVCS)
  1.  D CHG72P1 ;          change file 9002172.1 (CDMIS VISIT)
  1.  D CHG72P7 ;          change file 9002172.7 (CDMIS CLIENT SVCS COPY SET)
  1.  D CHG73P5 ;          change file 9002173.5 (CDMIS NTERVENTIONS)
  1.  ;
  1.  S X="1",DIC="^ACDCNV(",DIC(0)="L"
  1.  K DD,DO
  1.  D FILE^DICN
  1.  K D,D0,D1,DA,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM
  1.  I Y<0 W !!,"Adding of CONVERSIION FLAG failed.  Notify programmer.",!!
  1.  Q
  1.  ;
  1. CHG70P7 ; CHANGE FILE 9002170.7
  1.  W !,"Changing file 9002170.7",!
  1.  D KILL
  1.  S D0=0
  1.  F  S D0=$O(^ACDPD(D0)) Q:'D0  I $D(^ACDPD(D0,0)) D
  1.  .  S Y=$P(^ACDPD(D0,0),U,5)
  1.  .  I Y S X=$$CONVERT I X S G="^ACDPD(",F=4,ACDIEN=D0 D REPFLD
  1.  .  S D1=0
  1.  .  F  S D1=$O(^ACDPD(D0,1,D1)) Q:'D1  I $D(^ACDPD(D0,1,D1,0)) D
  1.  ..  S D2=0
  1.  ..  F  S D2=$O(^ACDPD(D0,1,D1,"PRV",D2)) Q:'D2  I $D(^ACDPD(D0,1,D1,"PRV",D2,0)) D
  1.  ...  S Y=$P(^ACDPD(D0,1,D1,"PRV",D2,0),U)
  1.  ...  I Y S X=$$CONVERT I X S G="^ACDPD("_D0_",1,"_D1_",""PRV"",",F=.01,ACDIEN=D2 D REPFLD
  1.  ...  Q
  1.  ..  Q
  1.  .  Q
  1.  Q
  1.  ;
  1. CHG72 ; CHANGE FILE 9002172 
  1.  W !,"Changing file 9002172",!
  1.  D KILL
  1.  S D0=0
  1.  F  S D0=$O(^ACDCS(D0)) Q:'D0  I $D(^ACDCS(D0,0)) D
  1.  .  S D1=0
  1.  .  F  S D1=$O(^ACDCS(D0,1,D1)) Q:'D1  I $D(^ACDCS(D0,1,D1,0)) D
  1.  ..  S Y=$P(^ACDCS(D0,1,D1,0),U)
  1.  ..  I Y S X=$$CONVERT I X S G="^ACDCS("_D0_",1,",F=.01,ACDIEN=D1 D REPFLD
  1.  ..  Q
  1.  .  Q
  1.  Q
  1.  ;
  1. CHG72P1 ; CHANGE FILE 9002172.1
  1.  W !,"Changing file 9002172.1",!
  1.  D KILL
  1.  S D0=0
  1.  F  S D0=$O(^ACDVIS(D0)) Q:'D0  I $D(^ACDVIS(D0,0)) D
  1.  .  S Y=$P(^ACDVIS(D0,0),U,3)
  1.  .  I Y S X=$$CONVERT I X S G="^ACDVIS(",F=2,ACDIEN=D0 D REPFLD
  1.  .  Q
  1.  Q
  1.  ;
  1. CHG72P7 ; CHANGE FILE 9002172.7
  1.  W !,"Changing file 9002172.7",!
  1.  D KILL
  1.  S D0=0
  1.  F  S D0=$O(^ACDCSCS(D0)) Q:'D0  I $D(^ACDCSCS(D0,0)) D
  1.  .  S D1=0
  1.  .  F  S D1=$O(^ACDCSCS(D0,11,D1)) Q:'D1  I $D(^ACDCSCS(D0,11,D1,0)) D
  1.  ..  S D2=0
  1.  ..  F  S D2=$O(^ACDCSCS(D0,11,D1,11,D2)) Q:'D2  I $D(^ACDCSCS(D0,11,D1,11,D2,0)) D
  1.  ...  S Y=$P(^ACDCSCS(D0,11,D1,11,D2,0),U)
  1.  ...  I Y S X=$$CONVERT I X S G="^ACDCSCS("_D0_",11,"_D1_",11,",F=.01,ACDIEN=D2 D REPFLD
  1.  ...  Q
  1.  ..  Q
  1.  .  Q
  1.  Q
  1.  ;
  1. CHG73P5 ; CHANGE FILE 9002173.5
  1.  W !,"Changing file 9002173.5",!
  1.  D KILL
  1.  S D0=0
  1.  F  S D0=$O(^ACDINTV(D0)) Q:'D0  I $D(^ACDINTV(D0,0)) D
  1.  .  S D1=0
  1.  .  F  S D1=$O(^ACDINTV(D0,2,D1)) Q:'D1  I $D(^ACDINTV(D0,2,D1,0)) D
  1.  ..  S Y=$P(^ACDINTV(D0,2,D1,0),U)
  1.  ..  I Y S X=$$CONVERT I X S G="^ACDINTV("_D0_",2,",F=.01,ACDIEN=D1 D REPFLD
  1.  ..  Q
  1.  .  Q
  1.  Q
  1.  ;
  1. REPFLD ; REPOINT FIELD
  1.  NEW DA
  1.  D D0DA  ;      setup DA array
  1.  NEW D0,D1,D2
  1.  S DIE=G,DA=ACDIEN,DR=F_"///"_$S(F=.01:"`",1:"/")_X
  1.  ;L +@(DIE_DA_")"):5 I '$T W !,"Sorry, someone else is editing this record.  Try later." Q
  1.  D ^DIE
  1.  ;L -@(DIE_DA_")")
  1.  K D,D0,D1,DA,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM
  1.  K ACDIEN
  1.  Q
  1.  ;
  1. CONVERT() ; CONVERT FILE 6 POINTER TO FILE 200 POINTER
  1.  NEW E,M,ACDZR,X
  1.  S ACDZR=$$LGR^%ZOSV  ;                save file entry
  1.  D CONVERT2 ;                          see if ptr converts
  1.  I E D  S X="" ;                       write error
  1.  .  W ACDZR,!,"  "_$P($T(CONVERR+E),";;",2),!,"  "_M,!
  1.  .  Q
  1.  Q X
  1.  ;
  1. CONVERR ; ERROR DESCRIPTIONS
  1.  ;;Dangling pointer to file 6
  1.  ;;File 6 pointer not in file 16
  1.  ;;No A3 node in file 16
  1.  ;;A3 pointer null or not numeric
  1.  ;;No entry in file 200 for A3 pointer
  1.  ;
  1. CONVERT2 ;
  1.  S E=0
  1.  S M="File 6 ptr="_Y
  1.  I '$D(^DIC(6,Y,0)) S E=1 Q  ;         dangling 6 ptr
  1.  I '$D(^DIC(16,Y,0)) S E=2 Q  ;        6 ptr not in 16
  1.  I '$D(^DIC(16,Y,"A3")) S E=3 Q  ;     no A3 node in 16
  1.  S X=^DIC(16,Y,"A3")
  1.  I 'X S E=4 Q  ;                       A3 ptr null or not numeric
  1.  S M=M_", A3 ptr="_X
  1.  I '$D(^VA(200,X,0)) S E=5 Q  ;        no 200 entry for A3 ptr
  1.  Q
  1.  ;
  1. D0DA ; ----- Set DA array from D0 (etc).
  1.  F I=0:1 Q:'$D(@("D"_I))  S J=I
  1.  I J=0 S DA=D0 Q
  1.  F I=0:1 S DA(J)=@("D"_I) S J=J-1 Q:J<1
  1.  S DA=@("D"_(I+1))
  1.  Q
  1.  ;
  1. KILL ; ----- KILL D0, D1, ETC.
  1.  NEW I
  1.  F I=0:1 Q:'$D(@("D"_I))  K @("D"_I)
  1.  Q