- DVBCXFRB ;ALB/GTS-557/THM-LOAD TRANSFER MAIL MESSAGE ; 1/12/19 3:48pm
- ;;2.7;AMIE;**149,193,209**;Apr 10, 1995;Build 17
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- EN ;file 2
- N DVBSBRCH,DVBDTYPE
- K ^TMP("DVBCXFR",$J),L S X=^DVB(396.3,REQDA,0),DFN=$P(X,U,1)
- S X=^DPT(DFN,0),PNAM=$P(X,U,1),DOB=$P(X,U,3),SEX=$P(X,U,2),SSN=$P(X,U,9),POBC=$P(X,U,11),POBS=$P(X,U,12)
- S X=$S($D(^DPT(DFN,.11)):^(.11),1:""),ADR1=$P(X,U,1),ADR2=$P(X,U,2),ADR3=$P(X,U,3),CITY=$P(X,U,4),STATE=$P(X,U,5),ZIP=$P(X,U,6),CNTY=$P(X,U,7),ZIP4=$P(X,U,12)
- S CNTY=$S($D(^DIC(5,+STATE,1,+CNTY,0)):$P(^(0),U,1),1:""),STATE=$S($D(^DIC(5,+STATE,0)):$P(^(0),U,1),1:"")
- S X=$S($D(^DPT(DFN,.13)):^(.13),1:"") S HOMPHON=$P(X,U,1),BUSPHON=$P(X,U,2)
- S X=$S($D(^DPT(DFN,.3)):^(.3),1:""),SRVCON=$P(X,U,1),SRVPCT=$P(X,U,2)
- S X=$S($D(^DPT(DFN,.31)):^(.31),1:""),CNUM=$P(X,U,3)
- S CFLOC=$$STATION^DVBAUTL1(DFN)
- S:CFLOC=-1 CFLOC=""
- S X=$S($D(^DPT(DFN,.32)):^(.32),1:""),PDSRV=$P(X,U,3),PDSRV=$S($D(^DIC(21,+PDSRV,0)):$P(^(0),U,3),1:"")
- S X=$$SVC^DVBCUTIL(DFN,"I"),SRVEDT=$P(X,U),SRVSDT=$P(X,U,2)
- S X=$$SVC^DVBCUTIL(DFN,"E"),DVBSBRCH=$P(X,U,3),DVBDTYPE=$P(X,U,4)
- S X=$S($D(^DPT(DFN,.36)):^(.36),1:""),ELIGCOD=$P(X,U,1),ELIGCOD=$S($D(^DIC(8,+ELIGCOD,0)):$P(^(0),U,9),1:"")
- S X=$S($D(^DPT(DFN,.361)):^(.361),1:""),ELIGST=$P(X,U,1),ELIGSDT=$P(X,U,2)
- S X=$S($D(^DPT(DFN,.52)):^(.52),1:""),POWSTAT=$P(X,U,5)
- S X=$S($D(^DPT(DFN,"VET")):^("VET"),1:""),VETST=$P(X,U,1)
- S X=$S($D(^DPT(DFN,"TYPE")):^("TYPE"),1:"") S TYPE=$S(X]"":$P(^DG(391,X,0),U,1),1:"")
- S ICN=$$GETICN^MPIF001(DFN),CSPT=$P($G(^DGSL(38.1,DFN,0)),U,2)
- S PREF=$P($G(^DPT(DFN,"ENR")),"^",2)
- S LINE(1)="$DEM0 "_PNAM_U_DOB_U_SEX_U_SSN_U_POBC_U_POBS_U_ICN_U_PREF_U_CSPT
- ;S LINE(1)="$DEM0 "_PNAM_U_DOB_U_SEX_U_SSN
- S LINE(2)="$DEM1 "_ADR1_U_ADR2_U_ADR3_U_CITY_U_STATE_U_CNTY_U_ZIP_U_HOMPHON_U_BUSPHON_U_ZIP4
- S LINE(3)="$ELIG "_SRVCON_U_SRVPCT_U_CFLOC_U_CNUM_U_PDSRV_U_SRVEDT_U_SRVSDT_U_ELIGCOD_U_ELIGST_U_ELIGSDT_U_POWSTAT_U_VETST_U_TYPE_U_DVBSBRCH_U_DVBDTYPE
- ;
- ;file 396.3
- EN1 S X=^DVB(396.3,REQDA,0),RO=$P(X,U,3),RONAM=$P($G(^DIC(4,+RO,99)),U,1),REQDT=$P(X,U,2),FEXM=$P(X,U,9),PRIO=$P(X,U,10),OTHDIS=$P(X,U,11),LREXMDT=$P(X,U,20)
- S X=$S($D(^DVB(396.3,REQDA,1)):^(1),1:""),CFREQ=$P(X,U,2),OTHDOC=$P(X,U,3),LREXMDT=$P(X,U,7),OTHDIS1=$P(X,U,9),OTHDIS2=$P(X,U,10)
- S LINE(4)="$REQ0 "_REQDA_U_RO_U_PRIO_U_CFLOC_U_LREXMDT_U_CFREQ_U_LREXMDT_U_RONAM_U_U_REQDT
- S LINE(5)="$ODIS "_OTHDIS_U_OTHDIS1_U_OTHDIS2
- S EXAMS="$EXAM "_EXAMS,LINE(6)=EXAMS
- ;**NOTE: RONAM is now RO NUMBER
- LOAD S L=1,^TMP("DVBCXFR",$J,L,0)="$TRANSFER IN",L=L+1
- F X=1:1 Q:'$D(LINE(X)) S ^TMP("DVBCXFR",$J,L,0)=LINE(X),L=L+1
- F JI=0:0 S JI=$O(^DVB(396.3,REQDA,2,JI)) Q:JI="" S ^TMP("DVBCXFR",$J,L,0)="$REMK "_^DVB(396.3,REQDA,2,JI,0),L=L+1
- S SITE=$P(^XMB(1,1,0),U,1),SITE1=$P(^DIC(4.2,SITE,0),U,1)
- S USERNM=$P(^VA(200,DUZ,0),U,1),^TMP("DVBCXFR",$J,L,0)="$USER "_USERNM_U_SITE_U_SITE1,L=L+1
- S ^TMP("DVBCXFR",$J,L,0)="$END "
- N XMNODE
- S XMNODE=0
- F X=(L+1):1:(L+XMCNT) DO
- .S XMNODE=XMNODE+1
- .S ^TMP("DVBCXFR",$J,X,0)=XMVAR(XMNODE)
- S ^TMP("DVBCXFR",$J,X+1,0)="$END1 "
- ;
- SEND K XMZ
- ;S XMY("POSTMASTER@"_DOMNAM)=DOMNUM
- S XMY(DUZ)="",XMY("S.DVBA C PROCESS MAIL MESSAGE@"_DOMNAM)=DOMNUM,XMSUB="Transfer of C&P Exams",XMTEXT="^TMP(""DVBCXFR"",$J,",XMDUZ=DUZ D ^XMD
- I $D(XMZ) W !!,"Transmitted as message # "_XMZ_" from this site to "_DOMNAM,! H 3
- I '$D(XMZ) W !!,*7,"Message transmission error!",!,"Request WILL NOT be transferred!",!!,"Press RETURN " R ANS:DTIME S OUT=1 G KILL^DVBCUTIL
- ;if all ok, update main, sub-file
- F III=0:0 S III=$O(XEXAMS(III)) Q:III="" S DIE="^DVB(396.4,",DA=III,DR=".04///T;62///"_DOMNAM_";60////"_DT_";61///"_USERNM D ^DIE
- K DIE,DA,DR S DIE="^DVB(396.3,",DA=REQDA,DR="31///y;32///N"
- D ^DIE ;set transfer items
- K LINE,DOMNUM,DOMNUM1,^TMP("DVBCXFR",$J),XMDUZ,III,L,JI,JY,XMY,XMZ,XMSUB,XMTEXT,XMDUZ,DIE,DA,DR,TYPE
- G KILL^DVBCUTIL
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCXFRB 3945 printed Jan 18, 2025@02:55:42 Page 2
- DVBCXFRB ;ALB/GTS-557/THM-LOAD TRANSFER MAIL MESSAGE ; 1/12/19 3:48pm
- +1 ;;2.7;AMIE;**149,193,209**;Apr 10, 1995;Build 17
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- EN ;file 2
- +1 NEW DVBSBRCH,DVBDTYPE
- +2 KILL ^TMP("DVBCXFR",$JOB),L
- SET X=^DVB(396.3,REQDA,0)
- SET DFN=$PIECE(X,U,1)
- +3 SET X=^DPT(DFN,0)
- SET PNAM=$PIECE(X,U,1)
- SET DOB=$PIECE(X,U,3)
- SET SEX=$PIECE(X,U,2)
- SET SSN=$PIECE(X,U,9)
- SET POBC=$PIECE(X,U,11)
- SET POBS=$PIECE(X,U,12)
- +4 SET X=$SELECT($DATA(^DPT(DFN,.11)):^(.11),1:"")
- SET ADR1=$PIECE(X,U,1)
- SET ADR2=$PIECE(X,U,2)
- SET ADR3=$PIECE(X,U,3)
- SET CITY=$PIECE(X,U,4)
- SET STATE=$PIECE(X,U,5)
- SET ZIP=$PIECE(X,U,6)
- SET CNTY=$PIECE(X,U,7)
- SET ZIP4=$PIECE(X,U,12)
- +5 SET CNTY=$SELECT($DATA(^DIC(5,+STATE,1,+CNTY,0)):$PIECE(^(0),U,1),1:"")
- SET STATE=$SELECT($DATA(^DIC(5,+STATE,0)):$PIECE(^(0),U,1),1:"")
- +6 SET X=$SELECT($DATA(^DPT(DFN,.13)):^(.13),1:"")
- SET HOMPHON=$PIECE(X,U,1)
- SET BUSPHON=$PIECE(X,U,2)
- +7 SET X=$SELECT($DATA(^DPT(DFN,.3)):^(.3),1:"")
- SET SRVCON=$PIECE(X,U,1)
- SET SRVPCT=$PIECE(X,U,2)
- +8 SET X=$SELECT($DATA(^DPT(DFN,.31)):^(.31),1:"")
- SET CNUM=$PIECE(X,U,3)
- +9 SET CFLOC=$$STATION^DVBAUTL1(DFN)
- +10 if CFLOC=-1
- SET CFLOC=""
- +11 SET X=$SELECT($DATA(^DPT(DFN,.32)):^(.32),1:"")
- SET PDSRV=$PIECE(X,U,3)
- SET PDSRV=$SELECT($DATA(^DIC(21,+PDSRV,0)):$PIECE(^(0),U,3),1:"")
- +12 SET X=$$SVC^DVBCUTIL(DFN,"I")
- SET SRVEDT=$PIECE(X,U)
- SET SRVSDT=$PIECE(X,U,2)
- +13 SET X=$$SVC^DVBCUTIL(DFN,"E")
- SET DVBSBRCH=$PIECE(X,U,3)
- SET DVBDTYPE=$PIECE(X,U,4)
- +14 SET X=$SELECT($DATA(^DPT(DFN,.36)):^(.36),1:"")
- SET ELIGCOD=$PIECE(X,U,1)
- SET ELIGCOD=$SELECT($DATA(^DIC(8,+ELIGCOD,0)):$PIECE(^(0),U,9),1:"")
- +15 SET X=$SELECT($DATA(^DPT(DFN,.361)):^(.361),1:"")
- SET ELIGST=$PIECE(X,U,1)
- SET ELIGSDT=$PIECE(X,U,2)
- +16 SET X=$SELECT($DATA(^DPT(DFN,.52)):^(.52),1:"")
- SET POWSTAT=$PIECE(X,U,5)
- +17 SET X=$SELECT($DATA(^DPT(DFN,"VET")):^("VET"),1:"")
- SET VETST=$PIECE(X,U,1)
- +18 SET X=$SELECT($DATA(^DPT(DFN,"TYPE")):^("TYPE"),1:"")
- SET TYPE=$SELECT(X]"":$PIECE(^DG(391,X,0),U,1),1:"")
- +19 SET ICN=$$GETICN^MPIF001(DFN)
- SET CSPT=$PIECE($GET(^DGSL(38.1,DFN,0)),U,2)
- +20 SET PREF=$PIECE($GET(^DPT(DFN,"ENR")),"^",2)
- +21 SET LINE(1)="$DEM0 "_PNAM_U_DOB_U_SEX_U_SSN_U_POBC_U_POBS_U_ICN_U_PREF_U_CSPT
- +22 ;S LINE(1)="$DEM0 "_PNAM_U_DOB_U_SEX_U_SSN
- +23 SET LINE(2)="$DEM1 "_ADR1_U_ADR2_U_ADR3_U_CITY_U_STATE_U_CNTY_U_ZIP_U_HOMPHON_U_BUSPHON_U_ZIP4
- +24 SET LINE(3)="$ELIG "_SRVCON_U_SRVPCT_U_CFLOC_U_CNUM_U_PDSRV_U_SRVEDT_U_SRVSDT_U_ELIGCOD_U_ELIGST_U_ELIGSDT_U_POWSTAT_U_VETST_U_TYPE_U_DVBSBRCH_U_DVBDTYPE
- +25 ;
- +26 ;file 396.3
- EN1 SET X=^DVB(396.3,REQDA,0)
- SET RO=$PIECE(X,U,3)
- SET RONAM=$PIECE($GET(^DIC(4,+RO,99)),U,1)
- SET REQDT=$PIECE(X,U,2)
- SET FEXM=$PIECE(X,U,9)
- SET PRIO=$PIECE(X,U,10)
- SET OTHDIS=$PIECE(X,U,11)
- SET LREXMDT=$PIECE(X,U,20)
- +1 SET X=$SELECT($DATA(^DVB(396.3,REQDA,1)):^(1),1:"")
- SET CFREQ=$PIECE(X,U,2)
- SET OTHDOC=$PIECE(X,U,3)
- SET LREXMDT=$PIECE(X,U,7)
- SET OTHDIS1=$PIECE(X,U,9)
- SET OTHDIS2=$PIECE(X,U,10)
- +2 SET LINE(4)="$REQ0 "_REQDA_U_RO_U_PRIO_U_CFLOC_U_LREXMDT_U_CFREQ_U_LREXMDT_U_RONAM_U_U_REQDT
- +3 SET LINE(5)="$ODIS "_OTHDIS_U_OTHDIS1_U_OTHDIS2
- +4 SET EXAMS="$EXAM "_EXAMS
- SET LINE(6)=EXAMS
- +5 ;**NOTE: RONAM is now RO NUMBER
- LOAD SET L=1
- SET ^TMP("DVBCXFR",$JOB,L,0)="$TRANSFER IN"
- SET L=L+1
- +1 FOR X=1:1
- if '$DATA(LINE(X))
- QUIT
- SET ^TMP("DVBCXFR",$JOB,L,0)=LINE(X)
- SET L=L+1
- +2 FOR JI=0:0
- SET JI=$ORDER(^DVB(396.3,REQDA,2,JI))
- if JI=""
- QUIT
- SET ^TMP("DVBCXFR",$JOB,L,0)="$REMK "_^DVB(396.3,REQDA,2,JI,0)
- SET L=L+1
- +3 SET SITE=$PIECE(^XMB(1,1,0),U,1)
- SET SITE1=$PIECE(^DIC(4.2,SITE,0),U,1)
- +4 SET USERNM=$PIECE(^VA(200,DUZ,0),U,1)
- SET ^TMP("DVBCXFR",$JOB,L,0)="$USER "_USERNM_U_SITE_U_SITE1
- SET L=L+1
- +5 SET ^TMP("DVBCXFR",$JOB,L,0)="$END "
- +6 NEW XMNODE
- +7 SET XMNODE=0
- +8 FOR X=(L+1):1:(L+XMCNT)
- Begin DoDot:1
- +9 SET XMNODE=XMNODE+1
- +10 SET ^TMP("DVBCXFR",$JOB,X,0)=XMVAR(XMNODE)
- End DoDot:1
- +11 SET ^TMP("DVBCXFR",$JOB,X+1,0)="$END1 "
- +12 ;
- SEND KILL XMZ
- +1 ;S XMY("POSTMASTER@"_DOMNAM)=DOMNUM
- +2 SET XMY(DUZ)=""
- SET XMY("S.DVBA C PROCESS MAIL MESSAGE@"_DOMNAM)=DOMNUM
- SET XMSUB="Transfer of C&P Exams"
- SET XMTEXT="^TMP(""DVBCXFR"",$J,"
- SET XMDUZ=DUZ
- DO ^XMD
- +3 IF $DATA(XMZ)
- WRITE !!,"Transmitted as message # "_XMZ_" from this site to "_DOMNAM,!
- HANG 3
- +4 IF '$DATA(XMZ)
- WRITE !!,*7,"Message transmission error!",!,"Request WILL NOT be transferred!",!!,"Press RETURN "
- READ ANS:DTIME
- SET OUT=1
- GOTO KILL^DVBCUTIL
- +5 ;if all ok, update main, sub-file
- +6 FOR III=0:0
- SET III=$ORDER(XEXAMS(III))
- if III=""
- QUIT
- SET DIE="^DVB(396.4,"
- SET DA=III
- SET DR=".04///T;62///"_DOMNAM_";60////"_DT_";61///"_USERNM
- DO ^DIE
- +7 KILL DIE,DA,DR
- SET DIE="^DVB(396.3,"
- SET DA=REQDA
- SET DR="31///y;32///N"
- +8 ;set transfer items
- DO ^DIE
- +9 KILL LINE,DOMNUM,DOMNUM1,^TMP("DVBCXFR",$JOB),XMDUZ,III,L,JI,JY,XMY,XMZ,XMSUB,XMTEXT,XMDUZ,DIE,DA,DR,TYPE
- +10 GOTO KILL^DVBCUTIL