DVBARL21 ;ALB/GTS-557/THM-EDIT 21 DAY CERTIFICATE TEXT ;21 JUL 89@0600
;;2.7;AMIE;;Apr 10, 1995
;
I $D(DUZ)#2=0 W *7,!!,"You have no user number.",!! H 3 Q
TERM D HOME^%ZIS S OPER=$S($D(^VA(200,+DUZ,0)):$P(^(0),U,1),1:"Unknown"),HD="21-DAY CERTIFICATE TEXT ENTRY/EDITING"
S DVBAENTR=0
;
SETUP D UNLOCK^DVBAUTL6(DVBAENTR)
K DVBAQUIT W @IOF S DIE="^DVB(396,",DR="6.81;D RELEASE^DVBARL21 I $D(DVBAQUIT) S Y=""@99"";6.82////R;6.83////"_DT_";6.84///"_OPER_";W !!,""This record is now released."",!! H 2;@99",DIC=DIE,DIC(0)="AEQM",DIC("A")="Enter PATIENT NAME: "
I '$D(^XUSEC("DVBA 21-DAY CERT CLERK",+DUZ)) W !!,*7,"You do not have the proper key to use this option.",!! H 3 G EXIT
D DICW^DVBAUTIL
;
EDIT D ^DIC G:X=U!(X="") EXIT W:Y<0 *7," ??" G:Y<0 EDIT
S OUT=0
I '$$LOCK^DVBAUTL6(Y) G SETUP
I Y>0 S DVBAENTR=+Y,DA=+$P(Y,U,1),DFN=$P(Y,U,2),NAME=$P(^DPT(DFN,0),U,1),SSN=$P(^(0),U,9) W !!
I $D(^DVB(396,DA,2)) I $P(^(2),U,10)="L" W !!,*7,"Wrong request type !",!,"This is an ACTIVITY DATE request, not ADMISSION DATE.",!! H 3 G SETUP
;I $P(^DVB(396,DA,1),U,12)]"" W !!,*7,"This request has already been FINALIZED and the text may not be changed.",!! H 3 G SETUP ;for future revisions
I $P(^DVB(396,DA,0),U,7)'="YES" W *7,!!,"No 21-day certificate has been requested for this Veteran.",!! H 3 G SETUP
I $P(^DVB(396,DA,0),U,7)="YES",'$D(^(4)) W !!,*7,"This Veteran has a 21-day certificate requested but",!," it has not yet been processed.",!! H 3 G SETUP
I $P(^DVB(396,DA,4),U,1)'="N" W !!,*7,"This certificate has been released to the RO",!,$S($P(^(4),U,1)="R":" but has not been printed.",$P(^(4),U,1)="P":" and has already been printed.",1:" but the status is unknown."),!! H 3 G SETUP
S Y=$P(^DVB(396,DA,0),U,4) X ^DD("DD") S ADMDT=Y
H 1 W @IOF,!?(79-$L(HD)\2),HD,!!!,?15,"Name: ",NAME,!,?16,"SSN: ",SSN,?40,"Admit date: ",ADMDT,!!! D ^DIE
G SETUP
;
EXIT W @IOF K DVBAENTR,OUT,WWHO,DVBAQUIT G KILL^DVBAUTIL
Q
RELEASE ;verify release is ok
I '$D(^XUSEC("DVBA RELEASE 21-DAY CERT",+DUZ)) S DVBAQUIT=1 Q
W !!,"Ok to release this 21-day certificate text" S %=2 D YN^DICN
I $D(%Y) I %Y["?" W !!,"Enter Y to go ahead and release this certificate to the RO",!,"or N to be able to make corrections and release later.",!! G RELEASE
I %'=1 S DVBAQUIT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBARL21 2304 printed Nov 22, 2024@16:52:18 Page 2
DVBARL21 ;ALB/GTS-557/THM-EDIT 21 DAY CERTIFICATE TEXT ;21 JUL 89@0600
+1 ;;2.7;AMIE;;Apr 10, 1995
+2 ;
+3 IF $DATA(DUZ)#2=0
WRITE *7,!!,"You have no user number.",!!
HANG 3
QUIT
TERM DO HOME^%ZIS
SET OPER=$SELECT($DATA(^VA(200,+DUZ,0)):$PIECE(^(0),U,1),1:"Unknown")
SET HD="21-DAY CERTIFICATE TEXT ENTRY/EDITING"
+1 SET DVBAENTR=0
+2 ;
SETUP DO UNLOCK^DVBAUTL6(DVBAENTR)
+1 KILL DVBAQUIT
WRITE @IOF
SET DIE="^DVB(396,"
SET DR="6.81;D RELEASE^DVBARL21 I $D(DVBAQUIT) S Y=""@99"";6.82////R;6.83////"_DT_";6.84///"_OPER_";W !!,""This record is now released."",!! H 2;@99"
SET DIC=DIE
SET DIC(0)="AEQM"
SET DIC("A")="Enter PATIENT NAME: "
+2 IF '$DATA(^XUSEC("DVBA 21-DAY CERT CLERK",+DUZ))
WRITE !!,*7,"You do not have the proper key to use this option.",!!
HANG 3
GOTO EXIT
+3 DO DICW^DVBAUTIL
+4 ;
EDIT DO ^DIC
if X=U!(X="")
GOTO EXIT
if Y<0
WRITE *7," ??"
if Y<0
GOTO EDIT
+1 SET OUT=0
+2 IF '$$LOCK^DVBAUTL6(Y)
GOTO SETUP
+3 IF Y>0
SET DVBAENTR=+Y
SET DA=+$PIECE(Y,U,1)
SET DFN=$PIECE(Y,U,2)
SET NAME=$PIECE(^DPT(DFN,0),U,1)
SET SSN=$PIECE(^(0),U,9)
WRITE !!
+4 IF $DATA(^DVB(396,DA,2))
IF $PIECE(^(2),U,10)="L"
WRITE !!,*7,"Wrong request type !",!,"This is an ACTIVITY DATE request, not ADMISSION DATE.",!!
HANG 3
GOTO SETUP
+5 ;I $P(^DVB(396,DA,1),U,12)]"" W !!,*7,"This request has already been FINALIZED and the text may not be changed.",!! H 3 G SETUP ;for future revisions
+6 IF $PIECE(^DVB(396,DA,0),U,7)'="YES"
WRITE *7,!!,"No 21-day certificate has been requested for this Veteran.",!!
HANG 3
GOTO SETUP
+7 IF $PIECE(^DVB(396,DA,0),U,7)="YES"
IF '$DATA(^(4))
WRITE !!,*7,"This Veteran has a 21-day certificate requested but",!," it has not yet been processed.",!!
HANG 3
GOTO SETUP
+8 IF $PIECE(^DVB(396,DA,4),U,1)'="N"
WRITE !!,*7,"This certificate has been released to the RO",!,$SELECT($PIECE(^(4),U,1)="R":" but has not been printed.",$PIECE(^(4),U,1)="P":" and has already been printed.",1:" but the status is unknown."),!!
HANG 3
GOTO SETUP
+9 SET Y=$PIECE(^DVB(396,DA,0),U,4)
XECUTE ^DD("DD")
SET ADMDT=Y
+10 HANG 1
WRITE @IOF,!?(79-$LENGTH(HD)\2),HD,!!!,?15,"Name: ",NAME,!,?16,"SSN: ",SSN,?40,"Admit date: ",ADMDT,!!!
DO ^DIE
+11 GOTO SETUP
+12 ;
EXIT WRITE @IOF
KILL DVBAENTR,OUT,WWHO,DVBAQUIT
GOTO KILL^DVBAUTIL
+1 QUIT
RELEASE ;verify release is ok
+1 IF '$DATA(^XUSEC("DVBA RELEASE 21-DAY CERT",+DUZ))
SET DVBAQUIT=1
QUIT
+2 WRITE !!,"Ok to release this 21-day certificate text"
SET %=2
DO YN^DICN
+3 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to go ahead and release this certificate to the RO",!,"or N to be able to make corrections and release later.",!!
GOTO RELEASE
+4 IF %'=1
SET DVBAQUIT=1
+5 QUIT
