DVBCXFRE ;ALB/GTS - 557/THM-SEND BACK TRANSFERS WHEN RELEASED ; 5/30/91 9:42 AM
;;2.7;AMIE;**10,184,193**;Apr 10, 1995;Build 84
;
EN W !!,*7,"This request was transferred in.",!,"Please wait while I return it.",!! H 2
;
EN1 W @FF,!! S SITE=$P(^DVB(396.3,REQDA,0),U,22),DTTRNSC=$P(^(0),U,12),SITE1=$S($D(^DIC(4.2,+SITE,0)):$P(^(0),U,1),1:""),SITE=$S($P(^(0),U,3)]"":$P(^(0),U,3),1:SITE)
I SITE="" W !!,*7,"There is no home domain indicated.",!,"This request was not transferred in.",!! H 3 Q
S NREQDA=$S($D(^DVB(396.3,REQDA,1)):$P(^(1),U,8),1:"") I +NREQDA=0 W !!,*7,"The original request indicator is missing!",!,"I have no way to match it back at "_SITE1,!! H 3 Q
W !!,"Setting up return mail message ...",!! H 1
S L=3,^TMP("DVBCXFR",$J,1,0)="$TRANSFER OUT FROM V"_$$VERSION^XPDUTL("DVBA"),^TMP("DVBCXFR",$J,2,0)="$RQDA "_NREQDA_U_DTTRNSC_U_$P(^DVB(396.3,REQDA,0),U,18)_U_$P(^(0),"^",19) W ".."
I $D(ALLROPN) S ^TMP("DVBCXFR",$J,L,0)="$ROPN 1^",L=L+1 W "."
F JJ=0:0 S JJ=$O(^DVB(396.4,"C",REQDA,JJ)) Q:JJ="" S DIE="^DVB(396.4,",DA=JJ,DR="64///N" D ^DIE K DA,DIE,DR D RSLT,RSLT1
S ^TMP("DVBCXFR",$J,L,0)="$USER "_$S($D(^VA(200,+DUZ,0)):$P(^(0),U,1),1:"POSTMASTER")_U_SITE_U_SITE1,L=L+1 W "."
S ^TMP("DVBCXFR",$J,L,0)="$END ",L=L+1 W "."
S ^TMP("DVBCXFR",$J,L,0)=" ",L=L+1 W "."
S ^TMP("DVBCXFR",$J,L,0)=" DFN: `"_DFN_$E(" ",1,20-$L(DFN))_"SITE: "_DVBCSITE,L=L+1 W "."
S ^TMP("DVBCXFR",$J,L,0)=" REQUEST DATE: "_DVBCRDAT,L=L+1 W "."
;
S ^TMP("DVBCXFR",$J,L,0)=" ",L=L+1 W "."
S ^TMP("DVBCXFR",$J,L,0)="** NOTE: To view the patient using the DFN, paste the DFN number into the **",L=L+1 W "."
S ^TMP("DVBCXFR",$J,L,0)="** CAPRI Patient Selector 'Patient ID' field to find the patient. Be sure to **",L=L+1 W "."
S ^TMP("DVBCXFR",$J,L,0)="** include the ' (backward-apostrophe) character. **",L=L+1 W "."
S ^TMP("DVBCXFR",$J,L,0)=" ",L=L+1 W "."
S ^TMP("DVBCXFR",$J,L,0)="** This is an auto-generated email. Do not respond to this email address. **",L=L+1 W "."
;
H 1 W !!,"Message is now ready to send back ...",!! H 2
;
SEND ;set status now for manual return if auto send fails; skip reopens
;AJF;Request Status conversion
I '$D(ALLROPN) S DIC(0)="QM",(DIC,DIE)="^DVB(396.3,",DA=REQDA,DR="17////10" D ^DIE
K XMZ S XMY(DUZ)="",XMSUB="Return of Transferred C&P Exams",XMTEXT="^TMP(""DVBCXFR"",$J,",XMY("S.DVBA C PROCESS MAIL MESSAGE@"_SITE1)=SITE D ^XMD
I $D(XMZ) W !!,"Transmitted as message # "_XMZ_" from this site to "_SITE1,! H 3
I '$D(XMZ) W !!,*7,"Message transmission error!",!,"Request WILL NOT be transferred!",!!,"Press RETURN " R ANS:DTIME S OUT=1 Q:'$D(MANUAL) I $D(MANUAL) K MANUAL G KILL^DVBCUTIL
K DIC,DIE,DR,DA,LN,^TMP("DVBCXFR",$J),XMZ,ANS,L,JY,XMY,XMSUB,XMTEXT,XMDUZ
I $D(MANUAL) K MANUAL G KILL^DVBCUTIL
Q
;
RSLT1 F LN=0:0 S LN=$O(^DVB(396.4,JJ,"RES",LN)) Q:LN="" S ^TMP("DVBCXFR",$J,L,0)="$RSLT "_^(LN,0),L=L+1 W "."
Q
;
MANUAL S MANUAL=1 D HOME^%ZIS S FF=IOF
;
MANUAL1 W @FF,!,"Manual Return of C&P Transfers",!!!!
K DIC S DIC="^DVB(396.3,",DIC(0)="AEQMZ",DIC("A")="Select VETERAN NAME: " D ^DIC G:X=""!(X=U) EXIT I +Y<0 W *7," ???" H 3 G MANUAL1
I '$P(^DVB(396.3,+Y,0),U,22) W *7,!!,"This request was not transferred in to this site and",!,"it is not possible to select it for return." K OUT D PAUSE G:$D(OUT) KILL^DVBCUTIL G MANUAL1
;AJF;Request Status conversion
I $P(^DVB(396.3,+Y,0),U,18)'=10 W !!,*7,"This request is not in the proper status to manually return it.",!,"The status must be COMPLETED/TRANSFERRED OUT (CT)." K OUT D PAUSE G:$D(OUT) KILL^DVBCUTIL G MANUAL1
;
ASK S REQDA=+Y W !!!,"Is this the correct request" S %=2 D YN^DICN G:%<0!($D(DTOUT)) EXIT I %=2 G MANUAL1
I %=0 W !!,"Enter Y if this is the correct request or N to re-select.",!! H 3 G ASK
S DFN=$P(^DVB(396.3,REQDA,0),U,1),SSN=$P(^DPT(DFN,0),U,9)
G EN1
;
EXIT K MANUAL,DIC,X,Y,REQDA,%,%Y,DTTRNSC,J,TSTDT,POP,STAT,RONAME,RO,JY,EXAM,C Q
;
RSLT S X=^DVB(396.4,JJ,0),WRKSHT=$P(X,U,5),EXSTAT=$P(X,U,4)
S CANCNODE=$S($D(^DVB(396.4,JJ,"CAN")):^DVB(396.4,JJ,"CAN"),1:""),CANCREM=$P(CANCNODE,U,3)
S CANCBY=$P(CANCNODE,U,2) S:CANCBY]"" CANCBY=.5
S CANCDT=$P(CANCNODE,U,1)
S EXMDT=$P(X,U,6),EXPHYS=$P(X,U,7),FEXM=$P(X,U,8),EXMPL=$P(X,U,9)
S ^TMP("DVBCXFR",$J,L,0)="$EXAM "_$P(^DVB(396.4,JJ,0),U,3)_U_WRKSHT_U_EXSTAT_U_CANCREM_U_CANCBY_U_CANCDT_U_EXMDT_U_EXPHYS_U_FEXM_U_EXMPL,L=L+1
K CANCNODE
Q
;
PAUSE W !!,"Press RETURN to continue or ""^"" to exit " R ANS:DTIME I ANS[U S OUT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCXFRE 4553 printed Dec 13, 2024@01:54:31 Page 2
DVBCXFRE ;ALB/GTS - 557/THM-SEND BACK TRANSFERS WHEN RELEASED ; 5/30/91 9:42 AM
+1 ;;2.7;AMIE;**10,184,193**;Apr 10, 1995;Build 84
+2 ;
EN WRITE !!,*7,"This request was transferred in.",!,"Please wait while I return it.",!!
HANG 2
+1 ;
EN1 WRITE @FF,!!
SET SITE=$PIECE(^DVB(396.3,REQDA,0),U,22)
SET DTTRNSC=$PIECE(^(0),U,12)
SET SITE1=$SELECT($DATA(^DIC(4.2,+SITE,0)):$PIECE(^(0),U,1),1:"")
SET SITE=$SELECT($PIECE(^(0),U,3)]"":$PIECE(^(0),U,3),1:SITE)
+1 IF SITE=""
WRITE !!,*7,"There is no home domain indicated.",!,"This request was not transferred in.",!!
HANG 3
QUIT
+2 SET NREQDA=$SELECT($DATA(^DVB(396.3,REQDA,1)):$PIECE(^(1),U,8),1:"")
IF +NREQDA=0
WRITE !!,*7,"The original request indicator is missing!",!,"I have no way to match it back at "_SITE1,!!
HANG 3
QUIT
+3 WRITE !!,"Setting up return mail message ...",!!
HANG 1
+4 SET L=3
SET ^TMP("DVBCXFR",$JOB,1,0)="$TRANSFER OUT FROM V"_$$VERSION^XPDUTL("DVBA")
SET ^TMP("DVBCXFR",$JOB,2,0)="$RQDA "_NREQDA_U_DTTRNSC_U_$PIECE(^DVB(396.3,REQDA,0),U,18)_U_$PIECE(^(0),"^",19)
WRITE ".."
+5 IF $DATA(ALLROPN)
SET ^TMP("DVBCXFR",$JOB,L,0)="$ROPN 1^"
SET L=L+1
WRITE "."
+6 FOR JJ=0:0
SET JJ=$ORDER(^DVB(396.4,"C",REQDA,JJ))
if JJ=""
QUIT
SET DIE="^DVB(396.4,"
SET DA=JJ
SET DR="64///N"
DO ^DIE
KILL DA,DIE,DR
DO RSLT
DO RSLT1
+7 SET ^TMP("DVBCXFR",$JOB,L,0)="$USER "_$SELECT($DATA(^VA(200,+DUZ,0)):$PIECE(^(0),U,1),1:"POSTMASTER")_U_SITE_U_SITE1
SET L=L+1
WRITE "."
+8 SET ^TMP("DVBCXFR",$JOB,L,0)="$END "
SET L=L+1
WRITE "."
+9 SET ^TMP("DVBCXFR",$JOB,L,0)=" "
SET L=L+1
WRITE "."
+10 SET ^TMP("DVBCXFR",$JOB,L,0)=" DFN: `"_DFN_$EXTRACT(" ",1,20-$LENGTH(DFN))_"SITE: "_DVBCSITE
SET L=L+1
WRITE "."
+11 SET ^TMP("DVBCXFR",$JOB,L,0)=" REQUEST DATE: "_DVBCRDAT
SET L=L+1
WRITE "."
+12 ;
+13 SET ^TMP("DVBCXFR",$JOB,L,0)=" "
SET L=L+1
WRITE "."
+14 SET ^TMP("DVBCXFR",$JOB,L,0)="** NOTE: To view the patient using the DFN, paste the DFN number into the **"
SET L=L+1
WRITE "."
+15 SET ^TMP("DVBCXFR",$JOB,L,0)="** CAPRI Patient Selector 'Patient ID' field to find the patient. Be sure to **"
SET L=L+1
WRITE "."
+16 SET ^TMP("DVBCXFR",$JOB,L,0)="** include the ' (backward-apostrophe) character. **"
SET L=L+1
WRITE "."
+17 SET ^TMP("DVBCXFR",$JOB,L,0)=" "
SET L=L+1
WRITE "."
+18 SET ^TMP("DVBCXFR",$JOB,L,0)="** This is an auto-generated email. Do not respond to this email address. **"
SET L=L+1
WRITE "."
+19 ;
+20 HANG 1
WRITE !!,"Message is now ready to send back ...",!!
HANG 2
+21 ;
SEND ;set status now for manual return if auto send fails; skip reopens
+1 ;AJF;Request Status conversion
+2 IF '$DATA(ALLROPN)
SET DIC(0)="QM"
SET (DIC,DIE)="^DVB(396.3,"
SET DA=REQDA
SET DR="17////10"
DO ^DIE
+3 KILL XMZ
SET XMY(DUZ)=""
SET XMSUB="Return of Transferred C&P Exams"
SET XMTEXT="^TMP(""DVBCXFR"",$J,"
SET XMY("S.DVBA C PROCESS MAIL MESSAGE@"_SITE1)=SITE
DO ^XMD
+4 IF $DATA(XMZ)
WRITE !!,"Transmitted as message # "_XMZ_" from this site to "_SITE1,!
HANG 3
+5 IF '$DATA(XMZ)
WRITE !!,*7,"Message transmission error!",!,"Request WILL NOT be transferred!",!!,"Press RETURN "
READ ANS:DTIME
SET OUT=1
if '$DATA(MANUAL)
QUIT
IF $DATA(MANUAL)
KILL MANUAL
GOTO KILL^DVBCUTIL
+6 KILL DIC,DIE,DR,DA,LN,^TMP("DVBCXFR",$JOB),XMZ,ANS,L,JY,XMY,XMSUB,XMTEXT,XMDUZ
+7 IF $DATA(MANUAL)
KILL MANUAL
GOTO KILL^DVBCUTIL
+8 QUIT
+9 ;
RSLT1 FOR LN=0:0
SET LN=$ORDER(^DVB(396.4,JJ,"RES",LN))
if LN=""
QUIT
SET ^TMP("DVBCXFR",$JOB,L,0)="$RSLT "_^(LN,0)
SET L=L+1
WRITE "."
+1 QUIT
+2 ;
MANUAL SET MANUAL=1
DO HOME^%ZIS
SET FF=IOF
+1 ;
MANUAL1 WRITE @FF,!,"Manual Return of C&P Transfers",!!!!
+1 KILL DIC
SET DIC="^DVB(396.3,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select VETERAN NAME: "
DO ^DIC
if X=""!(X=U)
GOTO EXIT
IF +Y<0
WRITE *7," ???"
HANG 3
GOTO MANUAL1
+2 IF '$PIECE(^DVB(396.3,+Y,0),U,22)
WRITE *7,!!,"This request was not transferred in to this site and",!,"it is not possible to select it for return."
KILL OUT
DO PAUSE
if $DATA(OUT)
GOTO KILL^DVBCUTIL
GOTO MANUAL1
+3 ;AJF;Request Status conversion
+4 IF $PIECE(^DVB(396.3,+Y,0),U,18)'=10
WRITE !!,*7,"This request is not in the proper status to manually return it.",!,"The status must be COMPLETED/TRANSFERRED OUT (CT)."
KILL OUT
DO PAUSE
if $DATA(OUT)
GOTO KILL^DVBCUTIL
GOTO MANUAL1
+5 ;
ASK SET REQDA=+Y
WRITE !!!,"Is this the correct request"
SET %=2
DO YN^DICN
if %<0!($DATA(DTOUT))
GOTO EXIT
IF %=2
GOTO MANUAL1
+1 IF %=0
WRITE !!,"Enter Y if this is the correct request or N to re-select.",!!
HANG 3
GOTO ASK
+2 SET DFN=$PIECE(^DVB(396.3,REQDA,0),U,1)
SET SSN=$PIECE(^DPT(DFN,0),U,9)
+3 GOTO EN1
+4 ;
EXIT KILL MANUAL,DIC,X,Y,REQDA,%,%Y,DTTRNSC,J,TSTDT,POP,STAT,RONAME,RO,JY,EXAM,C
QUIT
+1 ;
RSLT SET X=^DVB(396.4,JJ,0)
SET WRKSHT=$PIECE(X,U,5)
SET EXSTAT=$PIECE(X,U,4)
+1 SET CANCNODE=$SELECT($DATA(^DVB(396.4,JJ,"CAN")):^DVB(396.4,JJ,"CAN"),1:"")
SET CANCREM=$PIECE(CANCNODE,U,3)
+2 SET CANCBY=$PIECE(CANCNODE,U,2)
if CANCBY]""
SET CANCBY=.5
+3 SET CANCDT=$PIECE(CANCNODE,U,1)
+4 SET EXMDT=$PIECE(X,U,6)
SET EXPHYS=$PIECE(X,U,7)
SET FEXM=$PIECE(X,U,8)
SET EXMPL=$PIECE(X,U,9)
+5 SET ^TMP("DVBCXFR",$JOB,L,0)="$EXAM "_$PIECE(^DVB(396.4,JJ,0),U,3)_U_WRKSHT_U_EXSTAT_U_CANCREM_U_CANCBY_U_CANCDT_U_EXMDT_U_EXPHYS_U_FEXM_U_EXMPL
SET L=L+1
+6 KILL CANCNODE
+7 QUIT
+8 ;
PAUSE WRITE !!,"Press RETURN to continue or ""^"" to exit "
READ ANS:DTIME
IF ANS[U
SET OUT=1
+1 QUIT
