ACDAUTO ;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
;//^ACDDE
;
Q:'$G(ACDVISP)
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 an Initial or Re-open visit for you with a new"
W !,"component code/type that you select."
W !!,"If you plan to provide future services after discharge you should create an"
W !,"Initial for the AFTCARE component."
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 initial contact for component
S Y=0,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($G(^("BWP")),U)=ACDPGM,$P(ACDN0,U,2)=ACDCOMC,$P(ACDN0,U,4)="IN" S Y=1 Q
I ACDCONT=1,Y W !!!,*7,*7,"An INITIAL visit already exists for this component code.",!,"No new visit created. You may try again." D PAUSE^ACDDEU,GETVSITS^ACDDEU,DSPHIST^ACDDEU,K G EN1
I ACDCONT=2,'Y W !!!,*7,*7,"No INITIAL visit exists for this component code.",!,"No new visit created. You may try again." D PAUSE^ACDDEU,GETVSITS^ACDDEU,DSPHIST^ACDDEU,K G EN1
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////"_ACDVPGM_";1102////"_DUZ 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
; set variables for PCC link
I (ACDFHCP+ACDFPCC) S ACDPCCL(ACDDFNP,ACDBWP)="",ACDPCCL(ACDDFNP,ACDBWP,"IIF",ACDIIF)=""
F ACDMULT=2,3 F ACDMLEV=0:0 S ACDMLEV=$O(^ACDTDC(ACDDA,ACDMULT,ACDMLEV)) Q:'ACDMLEV S ACDPNTR=^(ACDMLEV,0) D
.S:ACDMULT=3 DIC("DR")=".02////"_$P(^ACDTDC(ACDDA,ACDMULT,ACDMLEV,0),U,2)
.S DA(1)=ACDIIF,DIC="^ACDIIF("_DA(1)_","_ACDMULT_",",DIC(0)="L",X=ACDPNTR S:'$D(@(DIC_"0)")) @(DIC_"0)")="^9002170."_$S(ACDMULT=2:"05",1:"01")_"PA" D FILE^ACDFMC
S DA=ACDIIF,DIK="^ACDIIF(" D IX1^DIK
I (ACDFHCP+ACDFPCC) S ACDPCCL(ACDDFNP,ACDVISP)="",ACDPCCL(ACDDFNP,ACDVISP,"IIF",ACDIIF)=""
W !!,"Finished auto creation..."
;
K ;
K ACDCOMC,ACDCOMT,ACDCONT,ACDDA,ACDIIF,ACDLINE,ACDMLEV,ACDMULT,ACDPNTR
Q
ACDAUTO ;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 ;//^ACDDE
+2 ;
+3 IF '$GET(ACDVISP)
QUIT
+4 IF '$DATA(ACDLINE)
SET $PIECE(ACDLINE,"=",80)="="
+5 WRITE @IOF,!,ACDLINE,!,*7,*7,*7,"Since you have created a new Transfer/Discharge/Close visit, I can now"
+6 WRITE !,"automatically create an Initial or Re-open visit for you with a new"
+7 WRITE !,"component code/type that you select."
+8 WRITE !!,"If you plan to provide future services after discharge you should create an"
+9 WRITE !,"Initial for the AFTCARE component."
+10 WRITE !,ACDLINE
+11 ;
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 initial contact for component
+15 SET Y=0
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($GET(^("BWP")),U)=ACDPGM
IF $PIECE(ACDN0,U,2)=ACDCOMC
IF $PIECE(ACDN0,U,4)="IN"
SET Y=1
QUIT
+16 IF ACDCONT=1
IF Y
WRITE !!!,*7,*7,"An INITIAL visit already exists for this component code.",!,"No new visit created. You may try again."
DO PAUSE^ACDDEU
DO GETVSITS^ACDDEU
DO DSPHIST^ACDDEU
DO K
GOTO EN1
+17 IF ACDCONT=2
IF 'Y
WRITE !!!,*7,*7,"No INITIAL visit exists for this component code.",!,"No new visit created. You may try again."
DO PAUSE^ACDDEU
DO GETVSITS^ACDDEU
DO DSPHIST^ACDDEU
DO K
GOTO EN1
+18 WRITE !!,"Filing new entry now...."
+19 SET ACD("V")=^ACDVIS(ACDVISP,0)
+20 SET $PIECE(ACD("V"),U,4)=$SELECT(ACDCONT=1:"IN",1:"RE")
+21 SET $PIECE(ACD("V"),U,2)=ACDCOMC
+22 SET $PIECE(ACD("V"),U,7)=ACDCOMT
+23 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////"_ACDVPGM_";1102////"_DUZ
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 ; set variables for PCC link
+5 IF (ACDFHCP+ACDFPCC)
SET ACDPCCL(ACDDFNP,ACDBWP)=""
SET ACDPCCL(ACDDFNP,ACDBWP,"IIF",ACDIIF)=""
+6 FOR ACDMULT=2,3
FOR ACDMLEV=0:0
SET ACDMLEV=$ORDER(^ACDTDC(ACDDA,ACDMULT,ACDMLEV))
IF 'ACDMLEV
QUIT
SET ACDPNTR=^(ACDMLEV,0)
Begin DoDot:1
+7 IF ACDMULT=3
SET DIC("DR")=".02////"_$PIECE(^ACDTDC(ACDDA,ACDMULT,ACDMLEV,0),U,2)
+8 SET DA(1)=ACDIIF
SET DIC="^ACDIIF("_DA(1)_","_ACDMULT_","
SET DIC(0)="L"
SET X=ACDPNTR
IF '$DATA(@(DIC_"0)"))
SET @(DIC_"0)")="^9002170."_$SELECT(ACDMULT=2:"05",1:"01")_"PA"
DO FILE^ACDFMC
End DoDot:1
+9 SET DA=ACDIIF
SET DIK="^ACDIIF("
DO IX1^DIK
+10 IF (ACDFHCP+ACDFPCC)
SET ACDPCCL(ACDDFNP,ACDVISP)=""
SET ACDPCCL(ACDDFNP,ACDVISP,"IIF",ACDIIF)=""
+11 WRITE !!,"Finished auto creation..."
+12 ;
K ;
+1 KILL ACDCOMC,ACDCOMT,ACDCONT,ACDDA,ACDIIF,ACDLINE,ACDMLEV,ACDMULT,ACDPNTR
+2 QUIT
