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

DGV53PT.m

Go to the documentation of this file. 
  1. DGV53PT ;alb/mjk - DG Post-Init Driver for v5.3 ;3/26/93
  1.  ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
  1.  ;
  1. EN ; -- main entry point
  1.  D LINE^DGVPP,^DGV53PT1   ; provider conversion (1-6)
  1.  D LINE^DGVPP,^DGV53PTI   ; IRT post init
  1.  D LINE^DGVPP,INCDATA     ; inconsistent data clean up
  1.  D LINE^DGVPP,EN^DGV53PTB ; bene travel
  1.  D LINE^DGVPP,EXPORT      ; install exported routines
  1.  D LINE^DGVPP,IVM         ; list templates affect by IVM
  1.  D LINE^DGVPP,^DGV53PTA   ; Alaska county codes
  1.  D LINE^DGVPP,^DGV53PTE   ; EDR conversion (late)
  1.  D UPEMB                  ; embossor DOB change (late)
  1.  D REL                    ; update pentecostal (very late)
  1. ENQ Q
  1.  ;
  1.  ;
  1. INCDATA ; -- inconsistent data cleanup
  1.  N DA,DFN,DIK
  1.  D STTIME^DGYPREG("Inconsistent Data file clean up")
  1.  W !!,">>> Deleting old inconsistencies from Inconsistent Data file"
  1.  F DFN=0:0 S DFN=$O(^DGIN(38.5,DFN)) Q:'DFN  W:'(DFN#100) "." F DA=46,47 D:$D(^DGIN(38.5,DFN,"I",DA,0))
  1.  .S DA(1)=DFN,DIK="^DGIN(38.5,"_DFN_",""I"","
  1.  .D ^DIK Q:$O(^DGIN(38.5,DFN,"I",0))
  1.  .S DIK="^DGIN(38.5,",DA=DFN
  1.  .D ^DIK
  1.  D ENDTIME^DGYPREG("Inconsistent Data file clean up")
  1.  Q
  1.  ;
  1. EXPORT ; -- Conditionally installs other package routines
  1.  N DIE,DIF,X,XCN,XCNP,DGTO,DGFR,DGI,DGX
  1.  W !!,">>> Will now load in routines for other packages, if appropriate..."
  1.  F DGI=1:1 S DGX=$T(ROU+DGI) Q:$P(DGX,";",3)="$END"  D
  1.  .S DGTO=$P(DGX,";",3),DGFR=$P(DGX,";",4) D LOAD(DGTO) D
  1.  ..S X=$G(^UTILITY("DGLOAD",$J,2,0)) X $P(DGX,";",5)
  1.  ..I $T D INSTALL(DGTO,DGFR)
  1.  K ^UTILITY("DGLOAD",$J)
  1. EXPORTQ Q
  1.  ;
  1. LOAD(DGTO) ; -- load current routine
  1.  K ^UTILITY("DGLOAD",$J)
  1.  S X=DGTO X ^%ZOSF("TEST")
  1.  I $T S XCNP=0,DIF="^UTILITY(""DGLOAD"",$J," X ^%ZOSF("LOAD")
  1.  Q
  1.  ;
  1. INSTALL(DGTO,DGFR) ; -- install routine
  1.  K ^UTILITY("DGLOAD",$J)
  1.  W !!?10," o  Installing ",DGTO," routine from ",DGFR," routine..."
  1.  S X=DGFR,XCNP=0,DIF="^UTILITY(""DGLOAD"",$J," X ^%ZOSF("LOAD")
  1.  S X=DGTO,XCN=3,DIE="^UTILITY(""DGLOAD"",$J," X ^%ZOSF("SAVE")
  1.  K ^UTILITY("DGLOAD",$J)
  1.  W !?15,DGTO,"...filed"
  1.  Q
  1.  ;
  1. ROU ; -- routines to export
  1.  ;;IBACKIN;DGVPTIB1;I $S(X="":1,1:X["1.5"),X'["*14",X'[",14"
  1.  ;;IBECEA3;DGVPTIB2;I $S(X="":1,1:X["1.5"),X'["*14",X'[",14"
  1.  ;;IBCNSP2;DGVPTIB3;I $S(X="":1,1:X["1.5"),X'["*14",X'[",14"
  1.  ;;IBCNSC;DGVPTIB4;I $S(X="":1,1:X["1.5"),X'["*14",X'[",14"
  1.  ;;IBOVOP1;DGVPTIB5;I $S(X="":1,1:X["1.5"),X'["*14",X'[",14"
  1.  ;;DGCRNS;DGVPTIB6;I $S(X="":1,1:X["1.5"),X'["*14",X'[",14"
  1.  ;;DVBHS5;DGVPTDV1;I $S(X="":1,1:X["4.0"),X'["*11",X'[",11"
  1.  ;;DVBHS1;DGVPTDV2;I $S(X="":1,1:X["4.0"),X'["*11",X'[",11"
  1.  ;;DVBHS2;DGVPTDV3;I $S(X="":1,1:X["4.0"),X'["*11",X'[",11"
  1.  ;;DVBHS6;DGVPTDV4;I $S(X="":1,1:X["4.0"),X'["*11",X'[",11"
  1.  ;;$END
  1.  ;
  1.  ;    piece 3 --> routine to replace
  1.  ;      "   4 --> post-init routine holding new verion
  1.  ;      "   5 --> 'ok to replace' IF test
  1.  ;                  - X will be defined to be the 2nd line of
  1.  ;                    current version
  1.  ;
  1. IVM ; -- notice about IVM affected templates
  1.  N I,J,X
  1.  W !!,">>> You will need to recompile the following input templates on"
  1.  W !,"    all CPU's using the routine ^DIEZ. These templates contain"
  1.  W !,"    patient fields that have had cross references added for IVM."
  1.  W !!,"    Please ensure that the same routine size is used on each system."
  1.  W !!?14,"Template",?40,"Routine",!?14,"--------",?40,"-------"
  1.  F I=1:1 S J=$P($T(TEMP+I),";;",2) Q:J="$END"  W !?14,$P(J,";",1),?40,$P(J,";",2)
  1.  ; AMIE 2.5 being released renames this template...add to list in IVM 1.5
  1.  S X="DVBA C ADD 2507 PAT" I $D(^DIE("B",X)) W !?14,X,?40,"DVBAXA"
  1.  S X="DVBC ADD 2507 PAT" I $D(^DIE("B",X)) W !?14,X,?40,"DVBAXA"
  1.  Q
  1.  ;
  1. TEMP ;
  1.  ;;DVBHINQ UPDATE;DVBHCE
  1.  ;;IB SCREEN1;IBXSC1
  1.  ;;$END
  1.  ;
  1. UPEMB ; -- update DOB field entry in file 39.2
  1.  I '$D(^DIC(39.2)) D  G QTEMB
  1.  .W !,">>> EMBOSSING DATA File (#39.2) was not found."
  1.  .W !?4,"PIMS Embosser software will not run properly without this file!"
  1.  .W !?4,"Contact your support ISC before using Embosser software.",!
  1.  N DGIFN
  1.  S DGIFN=$O(^DIC(39.2,"B","DOB",0))
  1.  I 'DGIFN!('$D(^DIC(39.2,+DGIFN,0)))!($G(^DIC(39.2,+DGIFN,1))="") D  G QTEMB
  1.  .W !,">>> 'DOB' MUMPS CODE entry not found in EMBOSSING DATA File (#39.2)"
  1.  .W !?4,"File was NOT updated...",!
  1.  ;NO MESSAGE IF DGIFN IS FOUND
  1.  S ^DIC(39.2,+DGIFN,1)="S (X,Y)="""" S:$D(^DPT(DFN,0)) X=$P(^(0),""^"",3) F I=4,6,2 S Z=$E(X,I,I+1) S:'Z Z=""00"" S Y=Y_Z"
  1. QTEMB Q
  1.  ;
  1. REL ; -- update religion
  1.  N DA,DIE,DR,DE,DQ
  1.  S DA=+$O(^DIC(13,"B","PENTACOSTAL",0))
  1.  I DA S DIE=13,DR=".01///PENTECOSTAL" D ^DIE
  1.  Q