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

ACDCREAT.m

Go to the documentation of this file. 
  1. ACDCREAT ;IHS/ADC/EDE/KML - AUTO-CREATE AN INITIAL OR REOPEN;
  1.  ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
  1.  ;***************************************************************
  1.  ;ACDVISP=DA
  1.  ;ACDDFNP=PATIENT
  1.  ;Auto create may be executed only if the user has just finished
  1.  ;adding a new entry and the contact type was 'TDC'
  1.  ;*****************************************************************
  1. EN ;EP
  1.  ;//^ACDDIC
  1.  Q:$G(DR)'="[ACD 1 (ADD)]"
  1.  S:'$D(ACDLINE) $P(ACDLINE,"=",80)="="
  1.  W @IOF,!,ACDLINE,!,*7,*7,*7,"Since you have created a new Transfer/Discharge/Close visit, I can now"
  1.  W !,"automatically create a Initial or Re-open visit for you with a new"
  1.  W !,"component code/type that you select." W !,ACDLINE
  1.  ;
  1. EN1 ;
  1.  S DIR("A")="Choose =>"
  1.  S DIR(0)="S^1:CREATE A NEW INITIAL VISIT;2:CREATE A NEW RE-OPEN VISIT;3:EXIT" D ^DIR
  1.  S ACDCONT=Y
  1.  G:X["^"!($D(DTOUT)) K I Y=3 W !!,"OK, no new visit created..." G K
  1.  ;
  1.  ;Get new component code
  1.  K DIR,X,Y S DIR(0)="P^9002170.1:AEQM" D ^DIR G:"^"[X!($D(DTOUT)) K
  1.  S ACDCOMC=+Y
  1.  ;
  1.  ;Get new component type
  1.  K DIR,X,Y S DIR(0)="9002172.1,5" D ^DIR G:"^"[X!($D(DTOUT)) K
  1.  S ACDCOMT=Y
  1.  ;
  1.  ;Check for duplicate intial contact for component
  1.  I ACDCONT=1 S DA=ACDVISP F ACDDA=0:0 S ACDDA=$O(^ACDVIS("D",ACDDFNP,ACDDA)) Q:'ACDDA  I ACDDA'=DA S ACDN0=^ACDVIS(ACDDA,0) I $P(ACDN0,U,2)=ACDCOMC,$P(ACDN0,U,4)="IN" D  D K G EN1
  1.  .W !!!,*7,*7,"A INITIAL visit already exists for this component code.",!,"No new visit created. You may try again."
  1.  W !!,"Filing new entry now...."
  1.  S ACD("V")=^ACDVIS(ACDVISP,0)
  1.  S $P(ACD("V"),U,4)=$S(ACDCONT=1:"IN",1:"RE")
  1.  S $P(ACD("V"),U,2)=ACDCOMC
  1.  S $P(ACD("V"),U,7)=ACDCOMT
  1.  S ACDVPGM=^ACDVIS(ACDVISP,"BWP")
  1. FILEV ;File visit into ^ACDVIS
  1.  S DIC="^ACDVIS(",X=$P(ACD("V"),U),DIC(0)="L" D FILE^ACDFMC
  1.  S ^ACDVIS(+Y,0)=ACD("V")
  1.  S ACDBWP=+Y
  1.  S DIE="^ACDVIS(",DA=ACDBWP,DR="99.99////^S X=ACDVPGM" D DIE^ACDFMC
  1.  S DA=ACDBWP,DIK="^ACDVIS(" D IX1^DIK
  1. IIF ;
  1.  S ACDDA=$O(^ACDTDC("C",ACDVISP,0))
  1.  S ACD("TDC")=^ACDTDC(ACDDA,0)
  1.  ;
  1.  S $P(ACD("IIF"),U)=$P(ACD("TDC"),U,27)
  1.  S $P(ACD("IIF"),U,2)=$P(ACD("TDC"),U,28)
  1.  S $P(ACD("IIF"),U,4)=$P(ACD("TDC"),U)
  1.  S $P(ACD("IIF"),U,5)=$P(ACD("TDC"),U,2)
  1.  S $P(ACD("IIF"),U,7)=$P(ACD("TDC"),U,4)
  1.  S $P(ACD("IIF"),U,8)=$P(ACD("TDC"),U,5)
  1.  S $P(ACD("IIF"),U,10)=$P(ACD("TDC"),U,7)
  1.  S $P(ACD("IIF"),U,11)=$P(ACD("TDC"),U,8)
  1.  S $P(ACD("IIF"),U,12)=$P(ACD("TDC"),U,9)
  1.  S $P(ACD("IIF"),U,13)=$P(ACD("TDC"),U,10)
  1.  S $P(ACD("IIF"),U,14)=$P(ACD("TDC"),U,11)
  1.  S $P(ACD("IIF"),U,15)=$P(ACD("TDC"),U,12)
  1.  S $P(ACD("IIF"),U,16)=$P(ACD("TDC"),U,13)
  1.  S $P(ACD("IIF"),U,17)=$P(ACD("TDC"),U,14)
  1.  S $P(ACD("IIF"),U,18)=$P(ACD("TDC"),U,15)
  1.  S $P(ACD("IIF"),U,19)=$P(ACD("TDC"),U,16)
  1.  S $P(ACD("IIF"),U,20)=$P(ACD("TDC"),U,17)
  1. FILEIIF ;File entry into ^ACDIIF
  1.  S DIC="^ACDIIF(",X=$P(ACD("IIF"),U),DIC(0)="L" D FILE^ACDFMC
  1.  S ^ACDIIF(+Y,0)=ACD("IIF"),^("BWP")=ACDBWP
  1.  S ACDIIF=+Y
  1.  F ACDRUG=0:0 S ACDRUG=$O(^ACDTDC(ACDDA,2,ACDRUG)) Q:'ACDRUG  S ACDPNTR=^(ACDRUG,0) D
  1.  .S DA(1)=ACDIIF,DIC="^ACDIIF("_DA(1)_",2,",DIC(0)="L",X=ACDPNTR S:'$D(@(DIC_"0)")) @(DIC_"0)")="^9002170.05PA" D FILE^ACDFMC
  1.  S DA=ACDIIF,DIK="^ACDIIF(" D IX1^DIK
  1.  W !!,"Finished auto creation..."
  1.  ;
  1. K ;
  1.  K DIR,ACDCONT,X,Y,ACDCOMC,ACDCOMT,ACD,ACDDA,DIC,ACDDA,ACDDRUG,ACDPNTR,DIK,DA,ACDIIF,ACDLINE