- DVBCXFRA ;ALB/GTS-557/THM-TRANSFER C&P REQUESTS ; 4/18/91 2:14 PM
- ;;2.7;AMIE;**193**;Apr 10, 1995;Build 84
- ;
- D HOME^%ZIS K CORR S FF=IOF G EN
- ;
- CORSEL I SEL=1 G EN
- I SEL=2 G DOMAIN
- I SEL=3 G EXAMS
- I SEL=4 K CORR,EXAMS,X,Y,REQDA G EN
- I SEL[U G EXIT
- ;
- SET ;** EXAMS - Xfr all
- S EXMNM=$P(^DVB(396.6,$P(^DVB(396.4,JJ,0),U,3),0),U,1)
- I $P(^DVB(396.4,JJ,0),U,4)["X" W EXMNM," is CANCELED and cannot be transferred.",!,*7 Q
- I $P(^DVB(396.4,JJ,0),U,4)="C" W EXMNM," is COMPLETED and cannot be transferred.",!,*7 Q
- I $P(^DVB(396.4,JJ,0),U,4)="T" W EXMNM," has been TRANSFERRED and cannot be selected.",!,*7 Q
- W !,EXMNM," is OK to transfer.",!!
- S EXAMS=EXAMS_$P(^DVB(396.4,JJ,0),U,3)_U,XEXAMS(JJ)="",XMCNT=XMCNT+1
- ;
- ;** Set XMVAR(XMCNT)=$EXAM AMIE EXAM IFN^INSUFF REASON IFN
- S XMVAR(XMCNT)="$EXAM "_$P(^DVB(396.4,JJ,0),U,3)_U_$S(+$P(^DVB(396.4,JJ,0),U,11)>0:$P(^DVB(396.94,$P(^DVB(396.4,JJ,0),U,11),0),U,1),1:"")
- ;EXAMS for MailMan msg, XEXAMS sets exam status
- ;XMVAR() add one exam/line to bulletin - Future
- Q
- ;
- EN W @FF,!,"Transfer C&P Exams",!!!!
- K DVBAINSF S DIC="^DVB(396.3,",DIC(0)="AEQMZ",DIC("A")="Select VETERAN NAME: " D ^DIC K DIC G:X=""!(X=U) EXIT I +Y<0 W *7," ???" H 2 G EN
- ;AJF ; Request Status Convertion
- I $P(Y(0),U,18)'=2 W !!,*7,"This request does not have a PENDING status and may not be transferred.",!! H 3 G EN
- I $P(Y(0),U,22)]"" W !!,*7,"This request was transferred in and CANNOT be transferred to any other site !",!! H 3 G EN
- ;
- ENQUEST W !!!,"Is this the correct request" S %=2 D YN^DICN G:%<0 EXIT I %=2 H 1 G EN
- I %=0 W !!,"Enter Y if the correct Veteran or N if not.",!! DO
- .D CONTMES^DVBCUTL4
- I %=0 G ENQUEST
- K DVBAINSF
- S REQDA=+Y,DFN=$P(Y,U,2),PNAM=$P(^DPT(DFN,0),U,1),SSN=$P(^(0),U,9)
- S:$P(^DVB(396.3,REQDA,0),U,10)="E" DVBAINSF=""
- I $D(CORR) G DISPLAY
- ;
- DOMAIN W @FF,!,"Selection of transfer domain:",!!!!
- S DIC("A")="Send to domain: ",DIC="^DIC(4.2,",DIC(0)="AEQM" D ^DIC G:X=""!(X=U) EXIT I +Y<0 W *7," ???" H 2 G EN
- ;
- DOMQST W !!!,"Is this the correct domain" S %=2 D YN^DICN G:%<0 EXIT I %=2 H 1 G DOMAIN
- I %=0 W !!,"Enter Y if the domain is correct or N to reselect." D CONTMES^DVBCUTL4 G DOMQST
- S DOMNUM=$S($P(^DIC(4.2,+Y,0),U,3)]"":$P(^(0),U,3),1:+Y),DOMNAM=$P(^(0),U,1),DOMNUM1=+Y
- I $D(CORR) G DISPLAY
- ;
- EXAMS K XEXAMS W @FF,!,"Exam selection",!!!! S EXAMS="",XMCNT=0
- F LPCNT=0:0 S LPCNT=$O(XMVAR(LPCNT)) Q:LPCNT="" K XMVAR(LPCNT)
- W !!,"Do you want to transfer ALL exams" S %=2 D YN^DICN G:%<0 EXIT
- I %=2 W !! G PART
- I %=0 W !!,"Enter Y if you want to transfer all exams or N if not.",!! D CONTMES^DVBCUTL4 G EXAMS
- W !!! F JJ=0:0 S JJ=$O(^DVB(396.4,"C",REQDA,JJ)) Q:JJ="" D SET
- D PAUSE^DVBCUTL4
- G @$S(EXAM]""&(Y):"DISPLAY",1:"EN")
- ;
- PART W @FF,!,"Individual exam selection",!!!!
- S Y=$$EXSRH^DVBCUTL4("Select EXAM TO TRANSFER: ","I $D(^DVB(396.4,""ARQ""_REQDA,+Y))") ;*Exam lookup function call
- K DIC G:X=""&(EXAMS]"") DISPLAY G:X=U EXIT
- I +Y<0 W *7,!!,"No exams have been selected for transfer." D CONTMES^DVBCUTL4 G EN
- I $P(^DVB(396.4,+Y,0),U,4)["X" W !!,"This exam is CANCELED and cannot be transferred.",*7,!! D CONTMES^DVBCUTL4 G PART
- I $P(^DVB(396.4,+Y,0),U,4)="C" W !!,"This exam has been COMPLETED and cannot be transferred.",!!,*7 D CONTMES^DVBCUTL4 G PART
- I $P(^DVB(396.4,+Y,0),U,4)="T" W !!,"This exam has been TRANSFERRED and cannot be selected.",!!,*7 D CONTMES^DVBCUTL4 G PART
- PART1 W !!!,"Is this the correct exam" S %=2 D YN^DICN G:%<0 EXIT I %=2 G EXAMS
- I %=0 W !!,"Enter Y if all is correct or N to reselect another exam." D CONTMES^DVBCUTL4 G PART1
- I EXAMS[$P(^DVB(396.4,+Y,0),U,3)_U DO
- .W !!,*7,"You have already selected this exam for transfer."
- .D CONTMES^DVBCUTL4
- I EXAMS[$P(^DVB(396.4,+Y,0),U,3)_U G PART
- S EXAMS=EXAMS_$P(^DVB(396.4,+Y,0),U,3)_U,XEXAMS(+Y)="",XMCNT=XMCNT+1
- D SETXMVR^DVBCXUTL ;** Set XMVAR(XMCNT)
- W !! G PART
- ;
- DISPLAY I EXAMS="" W @FF,!!!,"No exams have been selected for transfer.",!! D PAUSE^DVBCUTL4 G EN
- W @FF,!!,"You have selected the following:",!!!,"Veteran name: ",PNAM,?50,"SSN: ",SSN,!,"Request date: " S Y=$P(^DVB(396.3,REQDA,0),U,2) X ^DD("DD") W Y,!!!,"Exams selected for transfer:",!!
- F I=1:1 S X=$P(EXAMS,U,I) Q:X="" W $P(^DVB(396.6,X,0),U,1),"; " I $X>45 W !?2
- ;
- YN K DA(1) W !!!,"Is this information correct" S %=2 D YN^DICN I %<0 K EXAMS,REQDA,X,DIC,DA,Y,DVBAINSF,XMCNT F LPCNT=0:0 S LPCNT=$O(XMVAR(LPCNT)) Q:LPCNT="" K XMVAR(LPCNT)
- I %<0 K LPCNT G EN
- I %=0 W !!,"Answer YES if correct and NO if not" G YN
- I %=1 W !!,"One moment please ... "
- ;
- DISPLAY1 ;
- K CORR I %=2 S CORR=1 W @FF,!!,"Select part to correct:",!!!,"1. Veteran name",!,"2. Domain",!,"3. Exams",!,"4. All parts",!!,"Selection: " R SEL:DTIME G:'$T!(SEL[U) EXIT
- I $D(CORR) I (SEL'?1N)!(+SEL'>0)!(+SEL'<5)!(SEL["?") W *7,!!,"Must be a number from 1 to 4. " D CONTMES^DVBCUTL4 G DISPLAY1
- I $D(CORR) G CORSEL
- D INREAS^DVBCXUTL
- G ^DVBCXFRB
- ;
- EXIT D CLRVAR^DVBCXUTL
- D KILLVRS^DVBCXUTL G KILL^DVBCUTIL
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCXFRA 5032 printed Jan 18, 2025@02:55:41 Page 2
- DVBCXFRA ;ALB/GTS-557/THM-TRANSFER C&P REQUESTS ; 4/18/91 2:14 PM
- +1 ;;2.7;AMIE;**193**;Apr 10, 1995;Build 84
- +2 ;
- +3 DO HOME^%ZIS
- KILL CORR
- SET FF=IOF
- GOTO EN
- +4 ;
- CORSEL IF SEL=1
- GOTO EN
- +1 IF SEL=2
- GOTO DOMAIN
- +2 IF SEL=3
- GOTO EXAMS
- +3 IF SEL=4
- KILL CORR,EXAMS,X,Y,REQDA
- GOTO EN
- +4 IF SEL[U
- GOTO EXIT
- +5 ;
- SET ;** EXAMS - Xfr all
- +1 SET EXMNM=$PIECE(^DVB(396.6,$PIECE(^DVB(396.4,JJ,0),U,3),0),U,1)
- +2 IF $PIECE(^DVB(396.4,JJ,0),U,4)["X"
- WRITE EXMNM," is CANCELED and cannot be transferred.",!,*7
- QUIT
- +3 IF $PIECE(^DVB(396.4,JJ,0),U,4)="C"
- WRITE EXMNM," is COMPLETED and cannot be transferred.",!,*7
- QUIT
- +4 IF $PIECE(^DVB(396.4,JJ,0),U,4)="T"
- WRITE EXMNM," has been TRANSFERRED and cannot be selected.",!,*7
- QUIT
- +5 WRITE !,EXMNM," is OK to transfer.",!!
- +6 SET EXAMS=EXAMS_$PIECE(^DVB(396.4,JJ,0),U,3)_U
- SET XEXAMS(JJ)=""
- SET XMCNT=XMCNT+1
- +7 ;
- +8 ;** Set XMVAR(XMCNT)=$EXAM AMIE EXAM IFN^INSUFF REASON IFN
- +9 SET XMVAR(XMCNT)="$EXAM "_$PIECE(^DVB(396.4,JJ,0),U,3)_U_$SELECT(+$PIECE(^DVB(396.4,JJ,0),U,11)>0:$PIECE(^DVB(396.94,$PIECE(^DVB(396.4,JJ,0),U,11),0),U,1),1:"")
- +10 ;EXAMS for MailMan msg, XEXAMS sets exam status
- +11 ;XMVAR() add one exam/line to bulletin - Future
- +12 QUIT
- +13 ;
- EN WRITE @FF,!,"Transfer C&P Exams",!!!!
- +1 KILL DVBAINSF
- SET DIC="^DVB(396.3,"
- SET DIC(0)="AEQMZ"
- SET DIC("A")="Select VETERAN NAME: "
- DO ^DIC
- KILL DIC
- if X=""!(X=U)
- GOTO EXIT
- IF +Y<0
- WRITE *7," ???"
- HANG 2
- GOTO EN
- +2 ;AJF ; Request Status Convertion
- +3 IF $PIECE(Y(0),U,18)'=2
- WRITE !!,*7,"This request does not have a PENDING status and may not be transferred.",!!
- HANG 3
- GOTO EN
- +4 IF $PIECE(Y(0),U,22)]""
- WRITE !!,*7,"This request was transferred in and CANNOT be transferred to any other site !",!!
- HANG 3
- GOTO EN
- +5 ;
- ENQUEST WRITE !!!,"Is this the correct request"
- SET %=2
- DO YN^DICN
- if %<0
- GOTO EXIT
- IF %=2
- HANG 1
- GOTO EN
- +1 IF %=0
- WRITE !!,"Enter Y if the correct Veteran or N if not.",!!
- Begin DoDot:1
- +2 DO CONTMES^DVBCUTL4
- End DoDot:1
- +3 IF %=0
- GOTO ENQUEST
- +4 KILL DVBAINSF
- +5 SET REQDA=+Y
- SET DFN=$PIECE(Y,U,2)
- SET PNAM=$PIECE(^DPT(DFN,0),U,1)
- SET SSN=$PIECE(^(0),U,9)
- +6 if $PIECE(^DVB(396.3,REQDA,0),U,10)="E"
- SET DVBAINSF=""
- +7 IF $DATA(CORR)
- GOTO DISPLAY
- +8 ;
- DOMAIN WRITE @FF,!,"Selection of transfer domain:",!!!!
- +1 SET DIC("A")="Send to domain: "
- SET DIC="^DIC(4.2,"
- SET DIC(0)="AEQM"
- DO ^DIC
- if X=""!(X=U)
- GOTO EXIT
- IF +Y<0
- WRITE *7," ???"
- HANG 2
- GOTO EN
- +2 ;
- DOMQST WRITE !!!,"Is this the correct domain"
- SET %=2
- DO YN^DICN
- if %<0
- GOTO EXIT
- IF %=2
- HANG 1
- GOTO DOMAIN
- +1 IF %=0
- WRITE !!,"Enter Y if the domain is correct or N to reselect."
- DO CONTMES^DVBCUTL4
- GOTO DOMQST
- +2 SET DOMNUM=$SELECT($PIECE(^DIC(4.2,+Y,0),U,3)]"":$PIECE(^(0),U,3),1:+Y)
- SET DOMNAM=$PIECE(^(0),U,1)
- SET DOMNUM1=+Y
- +3 IF $DATA(CORR)
- GOTO DISPLAY
- +4 ;
- EXAMS KILL XEXAMS
- WRITE @FF,!,"Exam selection",!!!!
- SET EXAMS=""
- SET XMCNT=0
- +1 FOR LPCNT=0:0
- SET LPCNT=$ORDER(XMVAR(LPCNT))
- if LPCNT=""
- QUIT
- KILL XMVAR(LPCNT)
- +2 WRITE !!,"Do you want to transfer ALL exams"
- SET %=2
- DO YN^DICN
- if %<0
- GOTO EXIT
- +3 IF %=2
- WRITE !!
- GOTO PART
- +4 IF %=0
- WRITE !!,"Enter Y if you want to transfer all exams or N if not.",!!
- DO CONTMES^DVBCUTL4
- GOTO EXAMS
- +5 WRITE !!!
- FOR JJ=0:0
- SET JJ=$ORDER(^DVB(396.4,"C",REQDA,JJ))
- if JJ=""
- QUIT
- DO SET
- +6 DO PAUSE^DVBCUTL4
- +7 GOTO @$SELECT(EXAM]""&(Y):"DISPLAY",1:"EN")
- +8 ;
- PART WRITE @FF,!,"Individual exam selection",!!!!
- +1 ;*Exam lookup function call
- SET Y=$$EXSRH^DVBCUTL4("Select EXAM TO TRANSFER: ","I $D(^DVB(396.4,""ARQ""_REQDA,+Y))")
- +2 KILL DIC
- if X=""&(EXAMS]"")
- GOTO DISPLAY
- if X=U
- GOTO EXIT
- +3 IF +Y<0
- WRITE *7,!!,"No exams have been selected for transfer."
- DO CONTMES^DVBCUTL4
- GOTO EN
- +4 IF $PIECE(^DVB(396.4,+Y,0),U,4)["X"
- WRITE !!,"This exam is CANCELED and cannot be transferred.",*7,!!
- DO CONTMES^DVBCUTL4
- GOTO PART
- +5 IF $PIECE(^DVB(396.4,+Y,0),U,4)="C"
- WRITE !!,"This exam has been COMPLETED and cannot be transferred.",!!,*7
- DO CONTMES^DVBCUTL4
- GOTO PART
- +6 IF $PIECE(^DVB(396.4,+Y,0),U,4)="T"
- WRITE !!,"This exam has been TRANSFERRED and cannot be selected.",!!,*7
- DO CONTMES^DVBCUTL4
- GOTO PART
- PART1 WRITE !!!,"Is this the correct exam"
- SET %=2
- DO YN^DICN
- if %<0
- GOTO EXIT
- IF %=2
- GOTO EXAMS
- +1 IF %=0
- WRITE !!,"Enter Y if all is correct or N to reselect another exam."
- DO CONTMES^DVBCUTL4
- GOTO PART1
- +2 IF EXAMS[$PIECE(^DVB(396.4,+Y,0),U,3)_U
- Begin DoDot:1
- +3 WRITE !!,*7,"You have already selected this exam for transfer."
- +4 DO CONTMES^DVBCUTL4
- End DoDot:1
- +5 IF EXAMS[$PIECE(^DVB(396.4,+Y,0),U,3)_U
- GOTO PART
- +6 SET EXAMS=EXAMS_$PIECE(^DVB(396.4,+Y,0),U,3)_U
- SET XEXAMS(+Y)=""
- SET XMCNT=XMCNT+1
- +7 ;** Set XMVAR(XMCNT)
- DO SETXMVR^DVBCXUTL
- +8 WRITE !!
- GOTO PART
- +9 ;
- DISPLAY IF EXAMS=""
- WRITE @FF,!!!,"No exams have been selected for transfer.",!!
- DO PAUSE^DVBCUTL4
- GOTO EN
- +1 WRITE @FF,!!,"You have selected the following:",!!!,"Veteran name: ",PNAM,?50,"SSN: ",SSN,!,"Request date: "
- SET Y=$PIECE(^DVB(396.3,REQDA,0),U,2)
- XECUTE ^DD("DD")
- WRITE Y,!!!,"Exams selected for transfer:",!!
- +2 FOR I=1:1
- SET X=$PIECE(EXAMS,U,I)
- if X=""
- QUIT
- WRITE $PIECE(^DVB(396.6,X,0),U,1),"; "
- IF $X>45
- WRITE !?2
- +3 ;
- YN KILL DA(1)
- WRITE !!!,"Is this information correct"
- SET %=2
- DO YN^DICN
- IF %<0
- KILL EXAMS,REQDA,X,DIC,DA,Y,DVBAINSF,XMCNT
- FOR LPCNT=0:0
- SET LPCNT=$ORDER(XMVAR(LPCNT))
- if LPCNT=""
- QUIT
- KILL XMVAR(LPCNT)
- +1 IF %<0
- KILL LPCNT
- GOTO EN
- +2 IF %=0
- WRITE !!,"Answer YES if correct and NO if not"
- GOTO YN
- +3 IF %=1
- WRITE !!,"One moment please ... "
- +4 ;
- DISPLAY1 ;
- +1 KILL CORR
- IF %=2
- SET CORR=1
- WRITE @FF,!!,"Select part to correct:",!!!,"1. Veteran name",!,"2. Domain",!,"3. Exams",!,"4. All parts",!!,"Selection: "
- READ SEL:DTIME
- if '$TEST!(SEL[U)
- GOTO EXIT
- +2 IF $DATA(CORR)
- IF (SEL'?1N)!(+SEL'>0)!(+SEL'<5)!(SEL["?")
- WRITE *7,!!,"Must be a number from 1 to 4. "
- DO CONTMES^DVBCUTL4
- GOTO DISPLAY1
- +3 IF $DATA(CORR)
- GOTO CORSEL
- +4 DO INREAS^DVBCXUTL
- +5 GOTO ^DVBCXFRB
- +6 ;
- EXIT DO CLRVAR^DVBCXUTL
- +1 DO KILLVRS^DVBCXUTL
- GOTO KILL^DVBCUTIL