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

DG53142P.m

Go to the documentation of this file.
  1. DG53142P ;ALB/ABR - POST INSTALL ROUTINE ; 12 - Sep - 97
  1. ;;5.3;Registration;**142**;Aug 13, 1993
  1. ;
  1. ; This routine is being sent as an environment check routine
  1. ; in order to load code in advance that is needed for the
  1. ; Post-Install questions.
  1. ;
  1. ; There is no environment check done.
  1. ;
  1. EN ; ENVIRONMENT CHECK ENTRY POINT
  1. QUIT
  1. ;
  1. FTS ; code for the KIDS post-install questions.
  1. N DGX,DGY,DGZ
  1. S (DGY,DGZ)=$O(DIR("A",99),-1) ; find last line of DIR(A) for question
  1. F DGX=0:0 S DGX=$O(^DIC(45.7,"ASPEC",76,DGX)) Q:'DGX D
  1. . S DGY=DGY+1,DIR("A",DGY)=" "_$P($G(^DIC(45.7,DGX,0)),"^")
  1. I DGZ=DGY D
  1. . S DGY=DGY+1,DIR("A",DGY)=" ** No TREATING SPECIALTIES point to PTF CODE 76 **"
  1. . S DGY=DGY+1,DIR("A",DGY)=" ** Accept Default, no changes will be made to file 45.7"
  1. S DIR("A",DGY+1)=" "
  1. Q
  1. POS ; entry point for post-install
  1. N DGINA,ERR
  1. I $D(XPDQUES("POS1")) D Q:$G(ERR)
  1. .D ADDSP Q:$G(ERR)
  1. .D SPEC
  1. .D SUFFIX
  1. ;
  1. ; if Yes to inactivate Fac. Treating Specialty
  1. ; check if coming from KIDS install, or separate run
  1. ; DGINA=1 if yes to POST-INSTALL question, 0 if no
  1. ; DGINA=2 if direct run of routine (XPDQUES("POS1") not defined.)
  1. S DGINA=$G(XPDQUES("POS1"),2) D:DGINA INAFTS
  1. Q
  1. ;
  1. ADDSP ; add SPECIALTY 38 and 39
  1. N I
  1. F I=1,2 D
  1. . K DD,DO
  1. . N DA,DIC,DIE,DINUM,DLAYGO,DR,CDR,NAM,SPC,TXT,X,Y
  1. . S DLAYGO=42.4
  1. . S (DIC,DIE)="^DIC(42.4,",DIC(0)="XLZ"
  1. . S TXT=$P($T(ADDCO+I),";;",2),(X,NAM)=$P(TXT,U,2),(SPC,DINUM)=+TXT,CDR=$P(TXT,U,3)
  1. . D ^DIC
  1. . I Y<0 D BMES^XPDUTL(">> Error adding PTF CODE "_SPC_". Call Customer Support.") Q
  1. . I '$P(Y,U,3) S DA=SPC
  1. . S DR="1///^S X=NAM;3///^S X=""P"";4////1;5///^S X=""PSYCHIATRIC CARE"";6///"_CDR
  1. . D ^DIE
  1. . S (DIC,DIE)="^DIC(42.4,"_SPC_",""E"",",DA(1)=SPC,DIC("P")=$P(^DD(42.4,10,0),U,2),DIC(0)="XLZ"
  1. . S X=2971001
  1. . D BMES^XPDUTL(" >> Adding Specialty "_$P(TXT,U,2)_", PTF CODE "_+TXT)
  1. . D ^DIC I Y<0 D BMES^XPDUTL(">> Error adding PTF CODE Effective Date. Call Customer Support.") Q
  1. . S DR=".02////1",DA=+Y,DA(1)=SPC
  1. . D ^DIE
  1. Q
  1. ;
  1. ADDCO ;PTF CODE^NAME^CDR ACCT
  1. ;;38^PTSD CWT/TR^1716.00
  1. ;;39^GENERAL CWT/TR^1717.00
  1. Q
  1. SPEC ; inactivate SPECIALTY 76
  1. K DD,DO
  1. N DA,DIC,DIE,DR,X,Y
  1. S (DIC,DIE)="^DIC(42.4,76,""E"",",DIC(0)="XLZ",DIC("P")=$P(^DD(42.4,10,0),U,2)
  1. S X=2971001,DA(1)=76
  1. D ^DIC
  1. I Y<0 D BMES^XPDUTL(" >> Error inactivating PTF CODE 76. CALL CUSTOMER SUPPORT.") S ERR=1 Q
  1. I $P(Y(0),"^",2)=0 D BMES^XPDUTL("PTF CODE 76, PSYCHIATRIC MENTALLY INFIRM already inactive for 10/1/97") Q
  1. S DA=+Y,DA(1)=76,DR=".02////0"
  1. D ^DIE
  1. D MES^XPDUTL(">> Inactivating PTF CODE 76, PSYCHIATRIC MENTALLY INFIRM")
  1. D MES^XPDUTL(" from SPECIALTY file (#42.4)")
  1. Q
  1. ;
  1. SUFFIX ; Add Suffix
  1. K DD,DO
  1. N DA,DIC,DIE,DLAYGO,DR,X,Y
  1. S DLAYGO=45.68
  1. S DIC="^DIC(45.68,",DIC(0)="XLZ"
  1. S X="PA"
  1. D ^DIC I Y<0 D BMES^XPDUTL(">> Error adding PA Suffix. Call Customer Support.") Q
  1. D BMES^XPDUTL(" >> PA suffix added to FACILITY SUFFIX file.")
  1. S (DIC,DIE)="^DIC(45.68,"_+Y_",""E"",",DA(1)=+Y,DIC("P")=$P(^DD(45.68,10,0),U,2),DIC(0)="XLZ",X=2971001
  1. D ^DIC
  1. I Y<0 D BMES^XPDUTL(">> Error adding PA Suffix Effective Date. Call Customer Support.") Q
  1. S DA=+Y
  1. S DR=".01////2971001;.02////1"
  1. D ^DIE
  1. Q
  1. ;
  1. INAFTS ; inactivate associated facility treating specialties
  1. K DD,DO
  1. N DA,DIC,DIE,DR,X,Y,DGX,DGNAME,DGOKAY
  1. F DGX=0:0 S DGX=$O(^DIC(45.7,"ASPEC",76,DGX)) Q:'DGX D
  1. . S (DIC,DIE)="^DIC(45.7,"_DGX_",""E"",",DIC(0)="XLZ",DIC("P")=$P(^DD(45.7,100,0),U,2),DA(1)=DGX
  1. . S X=2971001
  1. . S DGNAME=$P(^DIC(45.7,DGX,0),"^")
  1. . ; if direct run of routine, get okay for each TS
  1. . I DGINA=2 S DGOKAY=0 D ASK Q:'DGOKAY
  1. . D ^DIC I Y<0 D BMES^XPDUTL(" >> Error updating file 45.7. CALL CUSTOMER SUPPORT.") Q
  1. . I $P(Y(0),"^",2)=0 D BMES^XPDUTL(DGNAME_" already inactivated for 10/1/97") Q
  1. . S DA=+Y,DA(1)=DGX,DR=".02////0"
  1. . D ^DIE
  1. .D BMES^XPDUTL(">> Inactivating FACILITY TREATING SPECIALTY: "_DGNAME)
  1. Q
  1. ;
  1. ASK ; for individual run, ask ok for each ts
  1. N DIR,X,Y
  1. S DIR("A")="Inactivate FACILITY TREATING SPECIALTY: "_DGNAME
  1. S DIR("A",1)=" ",DIR(0)="Y",DIR("B")="NO"
  1. D ^DIR S DGOKAY=+Y
  1. Q