Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DVBCLOGE

DVBCLOGE.m

Go to the documentation of this file.
  1. DVBCLOGE ;ALB/GTS-557/THM-SET UP C&P EXAM ; 5/10/91 8:55 AM
  1. ;;2.7;AMIE;;Apr 10, 1995
  1. ;if $D(OUT), request deleted - exams must be completed
  1. ;
  1. EXMHD K OUT N DVBARQDT,DVBADT,DVBADA
  1. W @FF,?(IOM-$L(HD2)\2),HD2
  1. W !!,"Please select the exams for ",$P(PNAM,",",2,99)," ",$P(PNAM,",",1)
  1. W !,"Use ? to see a list of exams available for selection.",!!
  1. I $D(^DVB(396.3,REQDA,5)),($P(^DVB(396.3,REQDA,0),"^",10)="E"&(+$P(^DVB(396.3,REQDA,5),"^",1)'>0)) DO
  1. .S TVAR(1,0)="0,0,0,1,0^NOTE: This request has a priority of Insufficient without a link"
  1. .S TVAR(2,0)="0,8,0,1:1,0^to a completed request."
  1. .S TVAR(3,0)="0,0,0,1:2,0^Use care to select the proper exam(s) to return as insufficient."
  1. .D WR^DVBAUTL4("TVAR")
  1. .K TVAR
  1. I '$D(^DVB(396.3,REQDA,5))&($P(^DVB(396.3,REQDA,0),"^",10)="E") DO
  1. .S TVAR(1,0)="0,0,0,1,0^NOTE: This request has a priority of Insufficient without a link"
  1. .S TVAR(2,0)="0,8,0,1:1,0^to a completed request."
  1. .S TVAR(3,0)="0,0,0,1:2,0^Use care to select the proper exam(s) to return as insufficient."
  1. .D WR^DVBAUTL4("TVAR")
  1. .K TVAR
  1. ;
  1. EXMSEL K DIC,OUT,DVBAQT I $D(DVBCLCKD) Q
  1. S DVBARQDT=$P(^DVB(396.3,REQDA,0),U,2)
  1. I $D(^DVB(396.3,REQDA,5)),(+$P(^DVB(396.3,REQDA,5),U,1)>0) DO
  1. .S DVBAINDA=+$P(^DVB(396.3,REQDA,5),U,1) ;**Exam Scr for Insuff 2507'S
  1. .S DIC("S")="I $D(^DVB(396.4,""ARQ"_DVBAINDA_""",Y))"
  1. S:'$D(DIC("S")) DIC("S")="I $P(^(0),U,5)'=""I"""
  1. S DIC="^DVB(396.6,"
  1. S DIC(0)="AEQM",DIC("A")="Select EXAM: " D ^DIC
  1. S:$D(DTOUT) OUT=1 D:$D(OUT) KVARS Q:$D(OUT)
  1. G:X=""!(X=U) EXMDIS ;Only out of EXMSEL
  1. I +Y>0 S EXMNM=$P(^DVB(396.6,+Y,0),U,1),EXMPTR=+Y
  1. I +Y<0 W " ???" G EXMSEL
  1. I $D(^TMP($J,"NEW",EXMNM)) W " Duplicate - ignored",!,*7 G EXMSEL
  1. I $D(^DVB(396.4,"APS",DFN,EXMPTR,"O"))>0 W *7," -- already ON FILE",!
  1. I $D(^DVB(396.4,"APS",DFN,EXMPTR,"O"))>0 S DVBAQT=1
  1. G:$D(DVBAQT) EXMSEL
  1. S ^TMP($J,"NEW",EXMNM)=+Y K Y G EXMSEL
  1. ;
  1. EXMDIS W @FF,!! K %,%Y,DIE,DIC G:$D(DVBCLCKD) EXMSEL
  1. I '$D(^TMP($J,"NEW")) W !!,*7,"You have not selected any exams.",!,"Do you want to try again" S %=1 D YN^DICN D:%=1 KVARS G:%=1 EXMHD I $D(DTOUT) S OUT=1 D KVARS Q
  1. I $D(%Y) I %Y["?" W !!,"Enter Y to go back and select exams or N to DELETE the entire request",!,"as well as any exams selected." D CONTMES^DVBCUTL4 G EXMDIS
  1. I $D(%) I %'=1 S OUT=1 D KVARS Q
  1. W !!,"You have selected these exams:",!! S EXMNM="" F JY=0:1 S EXMNM=$O(^TMP($J,"NEW",EXMNM)) Q:EXMNM="" W ?5,EXMNM,!
  1. W !,$S(JY'>1:"Is this exam",1:"Are these exams")," correct"
  1. S %=2 D YN^DICN G:%=1 EXMLOG ;Only out of EXMDIS
  1. I $D(DTOUT) S OUT=1 D KVARS Q
  1. I $D(%Y),%Y["?" W !,"Enter Y to go ahead and log the selected exams or N to modify the list." D CONTMES^DVBCUTL4 G EXMDIS
  1. ;
  1. EXMOD ;drop into - correct exams
  1. I $D(%),%=2 W @FF,!!!
  1. S DIC(0)="AEQM",DIC("A")="Enter EXAM to delete: "
  1. S DIC="^DVB(396.6,",DIC("S")="I $D(^TMP($J,""NEW"",$P(^(0),U,1)))"
  1. ;
  1. EXMOD1 K OUT D ^DIC
  1. S:$D(DTOUT) OUT=1 D:$D(OUT) KVARS Q:$D(OUT)
  1. G:X=""!(X=U) EXMASK ;Only out of EXMOD1
  1. S EXMNM=$P(^DVB(396.6,+Y,0),U,1)
  1. I +Y>0&($D(^TMP($J,"NEW",EXMNM))) K ^TMP($J,"NEW",EXMNM) W " Ok ..." H 1 G EXMOD1
  1. G EXMOD1
  1. ;
  1. EXMASK W @FF,!!,"Want to add more exams"
  1. S %=1 D YN^DICN G:%=1 EXMSEL ;select more exams
  1. I $D(DTOUT) S OUT=1 D KVARS Q
  1. I $D(%Y),%Y["?" W !!,"Enter Y to add more exams or N to go on and log existing selections." D CONTMES^DVBCUTL4 G EXMASK
  1. G EXMDIS ;display exams
  1. ;
  1. EXMLOG W !! S EXMNM="" K DR
  1. D STM^DVBCUTL4
  1. F DVBCJ=0:0 S EXMNM=$O(^TMP($J,"NEW",EXMNM)) Q:EXMNM="" S X=$$EXAM^DVBCUTL4 S:X=0 DVBCLCKD=1 Q:$D(DVBCLCKD) D EXMLOG1 Q:$D(OUT)
  1. S XRTN=$T(+0)
  1. D SPM^DVBCUTL4
  1. W:$D(DVBCLCKD) !!," Another user adding exams now...try again later."
  1. R:$D(DVBCLCKD) !," PRESS [Return] TO CONTINUE...",DVBCCONT:DTIME
  1. I $D(DVBCLCKD) D ROLLBCK^DVBCUTL4 G EXMDIS
  1. I $D(OUT) D KVARS Q
  1. H 2 K DA S DA=REQDA
  1. W @IOF,!,"Please enter any remarks for this request:",!!!
  1. S DR="23",DIE="^DVB(396.3," D ^DIE H 1
  1. K DIC,DIE,DR,EXMNM,DVBCDEL,Y,X,EXMPTR D KVARS
  1. Q
  1. ;
  1. EXMLOG1 ;called by EXMLOG
  1. K OUT,DD,DO S (DIC,DIE)="^DVB(396.4,",DIC(0)=""
  1. S DIC("DR")=".02////^S X=REQDA;.03////^S X=$P(^TMP($J,""NEW"",EXMNM),U,1);.04////O"
  1. D FILE^DICN
  1. I $D(Y),+Y>0 W:$X>50 ! W:$X>40&($L(EXMNM)>30) ! W EXMNM_" -added, "
  1. I $D(Y),+Y<0 W *7,"Exam addition error ! " S OUT=1
  1. D INSXM^DVBCUTA1
  1. I $D(DTOUT) W *7,"Exam addition error ! " S OUT=1 D ROLLBCK^DVBCUTL4
  1. Q
  1. ;
  1. KVARS ;Kill this routines variables
  1. K DVBARQDT,DVBADT,DVBADA,DVBAQT,DVBAINDA
  1. Q