DVBCADEX ;ALB/GTS - 557/THM-ADD C&P EXAMS TO REQUESTS, PART 1 ; 6/28/91 9:32 AM
;;2.7;AMIE;**184,193**;Apr 10, 1995;Build 84
;
N FF,HD,HD1,HD2,HD3
SETUP D HOME^%ZIS S FF=IOF,HD="Add a C & P Exam for",HD1="Veteran Selection",HD2="Exam selection",HD3="2507 Exam Addition"
;
EN ; Entry point
N DVBCARY,DVBCRDAT,DVBCSITE
K DVBCLCKD D KILL W @FF,!?(IOM-$L(HD3)\2),HD3,!!?(IOM-$L(HD1)\2),HD1,!!!
S DIC(0)="AEQM",DIC="^DVB(396.3,",DIC("A")="Select VETERAN NAME: "
S DIC("W")="D DICW^DVBCUTIL"
S:$D(DVBAROUS) DIC("S")="I $P(^(0),U,10)'=""E""" ;**DVBAROUS set by menu
D ^DIC G:X=""!(X=U) EXIT
S:+Y>0 EXCNT=0,(DA,REQDA)=+Y,DFN=$P(Y,U,2) I +Y<0 W " ???",*7 H 1 G EN
S X=^DVB(396.3,REQDA,0),OWNDOM=$P(X,U,22)
D GETS^DIQ(396.3,REQDA,"1;2","E","DVBCARY")
S DVBCRDAT=DVBCARY(396.3,REQDA_",",1,"E")
S DVBCSITE=DVBCARY(396.3,REQDA_",",2,"E")
I OWNDOM]"" W *7,!!,"This request is a TRANSFER IN and exams cannot be added.",!! H 3 G EN
;AJF;Request Status conversion
S STAT=$$RSTAT^DVBCUTL8($P(X,U,18)) K NCN
F DTB="X","RX","T","C","R","CT","NT" I STAT=DTB S NCN=1 Q
I $D(NCN) W !!,*7,"This request has been ",$S(STAT["X":"cancelled",STAT="T":"transcribed",STAT["C":"completed",STAT="R":"released",STAT="NT":"transferred in",1:"given an incorrect status"),".",!! H 3 G EN
S DTA=^DPT(DFN,0),PNAM=$P(DTA,U,1),SSN=$P(DTA,U,9),CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Unknown") S:CNUM="" CNUM="Unknown" D HDR,^DVBCEEXM W !!,"Press RETURN " R ANS:DTIME G:'$T EXIT
D ^DVBCADE2,KILL G:$D(OUT)!($D(DVBCLCKD)) EXIT
G EN
;
EXIT K DVBCLCKD G KILL^DVBCUTIL
;
HDR W @FF,?(IOM-$L(HD)\2),HD,!!,"Veteran name: ",$P(PNAM,",",2,99)," ",$P(PNAM,",",1),?55,"SSN: ",SSN,!?53,"C-NUM: ",CNUM,!
F LINE=1:1:IOM W "="
W ! Q
;
KILL K CNUM,DFN,DIK,DR,DTA,DXCOD,DXNUM,EDIT,EX,EXMNM,FMT,PNAM,SSN,PCT,SC,REQDA,CTIM,VX,JY,JJ,X,%,^TMP($J),Y,DA,DIC,DIE,ANS,%Y,%,DTOUT,DUOUT,TEMP,DVBCCONT
K DVBAINDA,DVBCARY,DVBCRDAT,DVBCSITE,DTB,DVBAROUS,EXCNT
K LINE,OUT,OWNDOM,STAT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCADEX 1994 printed Nov 22, 2024@16:53:34 Page 2
DVBCADEX ;ALB/GTS - 557/THM-ADD C&P EXAMS TO REQUESTS, PART 1 ; 6/28/91 9:32 AM
+1 ;;2.7;AMIE;**184,193**;Apr 10, 1995;Build 84
+2 ;
+3 NEW FF,HD,HD1,HD2,HD3
SETUP DO HOME^%ZIS
SET FF=IOF
SET HD="Add a C & P Exam for"
SET HD1="Veteran Selection"
SET HD2="Exam selection"
SET HD3="2507 Exam Addition"
+1 ;
EN ; Entry point
+1 NEW DVBCARY,DVBCRDAT,DVBCSITE
+2 KILL DVBCLCKD
DO KILL
WRITE @FF,!?(IOM-$LENGTH(HD3)\2),HD3,!!?(IOM-$LENGTH(HD1)\2),HD1,!!!
+3 SET DIC(0)="AEQM"
SET DIC="^DVB(396.3,"
SET DIC("A")="Select VETERAN NAME: "
+4 SET DIC("W")="D DICW^DVBCUTIL"
+5 ;**DVBAROUS set by menu
if $DATA(DVBAROUS)
SET DIC("S")="I $P(^(0),U,10)'=""E"""
+6 DO ^DIC
if X=""!(X=U)
GOTO EXIT
+7 if +Y>0
SET EXCNT=0
SET (DA,REQDA)=+Y
SET DFN=$PIECE(Y,U,2)
IF +Y<0
WRITE " ???",*7
HANG 1
GOTO EN
+8 SET X=^DVB(396.3,REQDA,0)
SET OWNDOM=$PIECE(X,U,22)
+9 DO GETS^DIQ(396.3,REQDA,"1;2","E","DVBCARY")
+10 SET DVBCRDAT=DVBCARY(396.3,REQDA_",",1,"E")
+11 SET DVBCSITE=DVBCARY(396.3,REQDA_",",2,"E")
+12 IF OWNDOM]""
WRITE *7,!!,"This request is a TRANSFER IN and exams cannot be added.",!!
HANG 3
GOTO EN
+13 ;AJF;Request Status conversion
+14 SET STAT=$$RSTAT^DVBCUTL8($PIECE(X,U,18))
KILL NCN
+15 FOR DTB="X","RX","T","C","R","CT","NT"
IF STAT=DTB
SET NCN=1
QUIT
+16 IF $DATA(NCN)
WRITE !!,*7,"This request has been ",$SELECT(STAT["X":"cancelled",STAT="T":"transcribed",STAT["C":"completed",STAT="R":"released",STAT="NT":"transferred in",1:"given an incorrect status"),".",!!
HANG 3
GOTO EN
+17 SET DTA=^DPT(DFN,0)
SET PNAM=$PIECE(DTA,U,1)
SET SSN=$PIECE(DTA,U,9)
SET CNUM=$SELECT($DATA(^DPT(DFN,.31)):$PIECE(^(.31),U,3),1:"Unknown")
if CNUM=""
SET CNUM="Unknown"
DO HDR
DO ^DVBCEEXM
WRITE !!,"Press RETURN "
READ ANS:DTIME
if '$TEST
GOTO EXIT
+18 DO ^DVBCADE2
DO KILL
if $DATA(OUT)!($DATA(DVBCLCKD))
GOTO EXIT
+19 GOTO EN
+20 ;
EXIT KILL DVBCLCKD
GOTO KILL^DVBCUTIL
+1 ;
HDR WRITE @FF,?(IOM-$LENGTH(HD)\2),HD,!!,"Veteran name: ",$PIECE(PNAM,",",2,99)," ",$PIECE(PNAM,",",1),?55,"SSN: ",SSN,!?53,"C-NUM: ",CNUM,!
+1 FOR LINE=1:1:IOM
WRITE "="
+2 WRITE !
QUIT
+3 ;
KILL KILL CNUM,DFN,DIK,DR,DTA,DXCOD,DXNUM,EDIT,EX,EXMNM,FMT,PNAM,SSN,PCT,SC,REQDA,CTIM,VX,JY,JJ,X,%,^TMP($JOB),Y,DA,DIC,DIE,ANS,%Y,%,DTOUT,DUOUT,TEMP,DVBCCONT
+1 KILL DVBAINDA,DVBCARY,DVBCRDAT,DVBCSITE,DTB,DVBAROUS,EXCNT
+2 KILL LINE,OUT,OWNDOM,STAT
+3 QUIT
