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

AXDRPOST.m

Go to the documentation of this file.
  1. AXDRPOST ; IHS OHPRD/LAB - IHS OHPRD/LAB - IHS OHPRD/LAB - POST INIT TO AXDR PACKAGE ; [ 07/26/94  8:09 AM ]
  1.  ;;7.2;IHS PATIENT MERGE;;MAR 29, 1994
  1.  ;
  1.  ;
  1.  ;caused by a bug in version 18 of fileman, routine DICR.
  1. START ;
  1.  W !!,"This post init will do the following:",!?5,"1).  Add several IHS specific options to the Kernel Merge utilities menu"
  1.  W !?5,"2)  Add several Patient Reg options to the Merge Menu"
  1.  W !?5,"3)  Re-index a cross reference on the Prescription file"
  1.  W !!,"This can be queued, if desired.",!
  1. QUEUE ;
  1.  K ZTSK
  1.  S DIR(0)="Y",DIR("A")="Do you want to QUEUE this to run in the background",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I Y=1 D TSKMN Q
  1.  I $D(DIRUT) W !,"Okay, you '^'ed out or timed out so I'm quitting.",! D XIT Q
  1.  D DRIVER
  1.  D XIT
  1.  Q
  1. TSKMN ;
  1.  S ZTIO="",ZTRTN="DRIVER^AXDRPOST",ZTDTH="",ZTDESC="AXDR PACKAGE POST-INIT" D ^%ZTLOAD D XIT K ZTSK Q
  1. XIT ;
  1.  K AXDRF,AXDRI,AXDRLAST,AXDRM,AXDRO,AXDRON,AXDRORD,AXDRQ,AXDRRG,AXDRSYN,AXDRTEXT,AXDRX,AXDRXX,AXDRY
  1.  K X,Y,DIE,DIU,DIV,DR,DA
  1.  Q
  1. DRIVER ;EP from taskman
  1.  D ADDMENU ;add menu options
  1.  D PSRX ;reindex APA on prescription file
  1.  D PACKAGE
  1.  D XIT
  1.  W:'$D(ZTQUEUED) !!,"Post init complete.",!
  1.  Q
  1. PACKAGE ;clean up old 20 nodes in package file to prevent error in merge
  1.  S AXDRX=0 F  S AXDRX=$O(^DIC(9.4,AXDRX)) Q:AXDRX'=+AXDRX  I $D(^DIC(9.4,AXDRX,20)) K ^DIC(9.4,AXDRX,20),^DIC(9.4,"AMRG",AXDRX)
  1.  K ^DIC(9.4,"AMRG")
  1.  ;RESET LAB MERGE ROUTINE IN PACKAGE
  1.  S AXDRX=$O(^DIC(9.4,"C","LR","")) G:'AXDRX SD
  1.  S ^DIC(9.4,AXDRX,20,0)="^9.402P^2^1"
  1.  S ^DIC(9.4,AXDRX,20,2,0)="2^^ALRMERG"
  1.  S ^DIC(9.4,AXDRX,20,2,1)="I $D(^DPT(XDRMRG(""FR""),""LR"")) S XDRZ=1"
  1.  S DA=AXDRX,DIK="^DIC(9.4," D IX1^DIK K DA,DIK
  1. SD ;RESET SD MERGE ROUTINE IN PACKAGE
  1.  S AXDRX=$O(^DIC(9.4,"C","SD","")) G:AXDRX="" CHS
  1.  S ^DIC(9.4,AXDRX,20,0)="^9.402P^2^1"
  1.  S ^DIC(9.4,AXDRX,20,2,0)="2^^SDZMERG"
  1.  S ^DIC(9.4,AXDRX,20,2,1)="I $D(^DPT(XDRMRG(""FR""),""S"")) S XDRZ=1"
  1.  S DA=AXDRX,DIK="^DIC(9.4," D IX1^DIK K DA,DIK
  1. CHS ;chs package
  1.  S AXDRX=$O(^DIC(9.4,"C","ACHS","")) Q:AXDRX=""
  1.  S ^DIC(9.4,AXDRX,20,0)="^9.402P^2^1"
  1.  S ^DIC(9.4,AXDRX,20,2,0)="2^^ACHSMERG"
  1.  S ^DIC(9.4,AXDRX,20,2,1)="D FR^ACHSMERG"
  1.  S DA=AXDRX,DIK="^DIC(9.4," D IX1^DIK K DA,DIK
  1.  Q
  1. PSRX ;reindex C on 52
  1.  W:'$D(ZTQUEUED) !!,"Re-indexing C xref on Prescription file.",!
  1.  S DIK="^PSRX(",DIK(1)="2^C" D ENALL^DIK
  1.  Q
  1. ADDMENU ;ADDS IHS SPECIFIC MENU OPTIONS
  1.  S AXDRM="XDR MAIN MENU"
  1.  S X=AXDRM,DIC="^DIC(19,",DIC(0)="L" D ^DIC Q:+Y<1  S AXDRRG=+Y K DIC,DA,DD
  1.  G:AXDRRG="" UTIL
  1.  W:'$D(ZTQUEUED) !!,"Options are being added to ",AXDRM,"...",!!
  1.  ;GET LAST IEN IN MULT
  1.  S X=0 F  S X=$O(^DIC(19,AXDRRG,10,X)) Q:X'=+X  S AXDRLAST=X
  1.  S AXDRTEXT="MAIN" F AXDRI=1:1 S AXDRX=$T(@AXDRTEXT+AXDRI),AXDRXX=$P(AXDRX,";;",2) Q:AXDRXX=""  D
  1.  .S AXDRSYN=$P(AXDRX,";;",3),AXDRORD=$P(AXDRX,";;",4),AXDRO=$P(AXDRX,";;",2)
  1.  .S AXDRON=$O(^DIC(19,"B",AXDRO,"")) Q:AXDRON=""
  1.  .Q:$D(^DIC(19,AXDRRG,10,"B",AXDRON))
  1.  .S AXDRLAST=AXDRLAST+1
  1.  .S ^DIC(19,AXDRRG,10,AXDRLAST,0)=AXDRON_U_AXDRSYN_U_AXDRORD
  1.  .S $P(^DIC(19,AXDRM,10,0),U,3)=AXDRLAST,$P(^(0),U,4)=AXDRLAST
  1.  .S DA=AXDRRG,DIK="^DIC(19," D IX1^DIK K DA,DIK
  1. UTIL ;
  1.  S AXDRM="XDR UTILITIES MENU"
  1.  S X=AXDRM,DIC="^DIC(19,",DIC(0)="L" D ^DIC Q:+Y<1  S AXDRRG=+Y K DIC,DA,DD
  1.  G:AXDRRG="" END
  1.  W:'$D(ZTQUEUED) !!,"Options are being added to ",AXDRM,"...",!!
  1.  ;GET LAST IEN IN MULT
  1.  S X=0 F  S X=$O(^DIC(19,AXDRRG,10,X)) Q:X'=+X  S AXDRLAST=X
  1.  S AXDRTEXT="UTILO" F AXDRI=1:1 S AXDRX=$T(@AXDRTEXT+AXDRI),AXDRXX=$P(AXDRX,";;",2) Q:AXDRXX=""  D
  1.  .S AXDRSYN=$P(AXDRX,";;",3),AXDRORD=$P(AXDRX,";;",4),AXDRO=$P(AXDRX,";;",2)
  1.  .S AXDRON=$O(^DIC(19,"B",AXDRO,"")) Q:AXDRON=""
  1.  .Q:$D(^DIC(19,AXDRRG,10,"B",AXDRON))
  1.  .S AXDRLAST=AXDRLAST+1
  1.  .S ^DIC(19,AXDRRG,10,AXDRLAST,0)=AXDRON_U_AXDRSYN_U_AXDRORD
  1.  .S $P(^DIC(19,AXDRRG,10,0),U,3)=AXDRLAST,$P(^(0),U,4)=AXDRLAST
  1.  .S DA=AXDRRG,DIK="^DIC(19," D IX1^DIK K DA,DIK
  1. END K AXDRM,AXDRRG,AXDRY,AXDRF,AXDRX,AXDRQ
  1.  K Y,X,DD,DIC,DA
  1.  Q
  1.  ;
  1. MAIN ;
  1.  ;;AGPAT;;PAT;;90
  1.  ;;AGVIEWONLY;;VIEW;;95
  1.  ;;AGSETSITE;;SITE;;99
  1. UTILO ;
  1.  ;;AXDR PRINT ALPHA PAT LIST;;APL;;90
  1.  ;;AXDR PRINT ALPHA SCORES;;APS;;95