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