ASDAMB ; IHS/ADC/PDW/ENM - APPT MADE BY ; [ 03/25/1999 11:48 AM ]
;;5.0;IHS SCHEDULING;;MAR 25, 1999
;
PAT ; -- ask user for patient
NEW DIC S DIC=9000001,DIC(0)="AEQM" D ^DIC Q:X=""!(X=U)
I Y<0 W " ??",*7 G PAT
S DFN=+Y
;
DATE ; -- ask user for starting date
K DIR,ASDBDT,ASDEDT
S DIR(0)="DO^::EX",DIR("A")="Select beginning date"
D ^DIR K DIR G PAT:$D(DIRUT),PAT:Y<1 S ASDBDT=Y
I '$O(^DPT(DFN,"S",Y)) D G PAT
. W !!,"NO APPOINTMENTS FOUND!",!
;
EDATE ; -- ask user for ending date
S DIR(0)="DO^::EX",DIR("A")="Select ending date"
D ^DIR K DIR G PAT:$D(DIRUT),PAT:Y<1 S ASDEDT=Y
;
D EN G PAT
;
EN ; -- main entry point for SD IHS APPT MADE BY
D EN^VALM("SD IHS APPT MADE BY")
D EXIT Q
;
HDR ; -- header code
S VALMHDR(1)=$$PAD("",16)_$$CONF^ASDUT
Q
;
INIT ; -- init variables and list array
NEW ASDX,ASDS,ASDL,ASDEND
K ASDLN,ASDNUM,^TMP("ASDAMB",$J)
S ASDX=ASDBDT,ASDEND=ASDEDT+.2400
F S ASDX=$O(^DPT(DFN,"S",ASDX)) Q:'ASDX!(ASDX>ASDEND) D
. S ASDS=^DPT(DFN,"S",ASDX,0)
. S ASDL=$$PAD($$FMTE^XLFDT(ASDX),20) ;appt dt
. S ASDL=ASDL_$$PAD($$VAL^XBDIQ1(44,$P(ASDS,U),.01),24)_" " ;clinic
. D FINDUSR
. I ASDU]"" S ASDL=ASDL_$$PAD($$VAL^XBDIQ1(200,ASDU,.01),17) ;made by
. I ASDU="" S ASDL=ASDL_$$PAD("??",17)
. I ASDM]"" S ASDL=ASDL_" "_$$FMTE^XLFDT(ASDM) ;appt made dt
. I ASDM="" S ASDL=ASDL_" ??"
. S ASDLN=$G(ASDLN)+1,ASDNUM=$G(ASDNUM)+1
. S ^TMP("ASDAMB",$J,ASDLN,0)=$J(ASDNUM,2)_". "_ASDL
. S ^TMP("ASDAMB",$J,"IDX",ASDLN,ASDNUM)=DFN_U_+ASDS_U_ASDX
S VALMCNT=+$G(ASDLN)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ASDBDT,ASDEDT,ASDA,ASDLN,ASDM,ASDNUM,ASDU,ASDX,AGE,SEX,DFN
K SDC,SDIFN,SDP,SDPP,SDS,SDSTAT,SSN,VALMY,ORX
K VALMBCK,VALMCNT,VALMHDR
Q
;
EXPND ; -- expand code
Q
;
RETURN ; -- reset variables for return to lt
D TERM^VALM0 S VALMBCK="R" Q
;
GETAPPT ; -- select appt from listing
D FULL^VALM1
S ASDA=""
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) Q
S X=$O(VALMY(0))
S Y=0 F S Y=$O(^TMP("ASDAMB",$J,"IDX",Y)) Q:Y="" Q:ASDA]"" D
. S Z=$O(^TMP("ASDAMB",$J,"IDX",Y,0))
. Q:^TMP("ASDAMB",$J,"IDX",Y,Z)=""
. I Z=X S ASDA=^TMP("ASDAMB",$J,"IDX",Y,Z)
Q:ASDA=""
S DFN=$P(ASDA,U),SDIFN=$P(ASDA,U,2),SDA=$P(ASDA,U,3)
Q
;
VA ;EP; called by View Appt action
S (DFN,SDIFN,SDA)="" D GETAPPT
I DFN=""!(SDIFN="")!(SDA="") D D RETURN Q
. W !,"Sorry data missing on this appointment!"
D ^XBCLS,P^SDCLK,PRTOPT^ASDVAR,RETURN
Q
;
FINDUSR ; -- gets user and date made from file 44
NEW X,Y
S Y=$P(^DPT(DFN,"S",ASDX,0),U,18,19)
I +Y S ASDU=$P(Y,U),ASDM=$P(Y,U,2) Q
K Y S X=0 F S X=$O(^SC(+ASDS,"S",ASDX,1,X)) Q:X=""!($D(Y)) D
. I +^SC(+ASDS,"S",ASDX,1,X,0)'=DFN Q
. S Y=$P(^SC(+ASDS,"S",ASDX,1,X,0),U,6,7)
S ASDU=$P($G(Y),U),ASDM=$P($G(Y),U,2)
Q
;
PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
Q $E(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
ASDAMB ; IHS/ADC/PDW/ENM - APPT MADE BY ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;IHS SCHEDULING;;MAR 25, 1999
+2 ;
PAT ; -- ask user for patient
+1 NEW DIC
SET DIC=9000001
SET DIC(0)="AEQM"
DO ^DIC
IF X=""!(X=U)
QUIT
+2 IF Y<0
WRITE " ??",*7
GOTO PAT
+3 SET DFN=+Y
+4 ;
DATE ; -- ask user for starting date
+1 KILL DIR,ASDBDT,ASDEDT
+2 SET DIR(0)="DO^::EX"
SET DIR("A")="Select beginning date"
+3 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO PAT
IF Y<1
GOTO PAT
SET ASDBDT=Y
+4 IF '$ORDER(^DPT(DFN,"S",Y))
Begin DoDot:1
+5 WRITE !!,"NO APPOINTMENTS FOUND!",!
End DoDot:1
GOTO PAT
+6 ;
EDATE ; -- ask user for ending date
+1 SET DIR(0)="DO^::EX"
SET DIR("A")="Select ending date"
+2 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO PAT
IF Y<1
GOTO PAT
SET ASDEDT=Y
+3 ;
+4 DO EN
GOTO PAT
+5 ;
EN ; -- main entry point for SD IHS APPT MADE BY
+1 DO EN^VALM("SD IHS APPT MADE BY")
+2 DO EXIT
QUIT
+3 ;
HDR ; -- header code
+1 SET VALMHDR(1)=$$PAD("",16)_$$CONF^ASDUT
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 NEW ASDX,ASDS,ASDL,ASDEND
+2 KILL ASDLN,ASDNUM,^TMP("ASDAMB",$JOB)
+3 SET ASDX=ASDBDT
SET ASDEND=ASDEDT+.2400
+4 FOR
SET ASDX=$ORDER(^DPT(DFN,"S",ASDX))
IF 'ASDX!(ASDX>ASDEND)
QUIT
Begin DoDot:1
+5 SET ASDS=^DPT(DFN,"S",ASDX,0)
+6 ;appt dt
SET ASDL=$$PAD($$FMTE^XLFDT(ASDX),20)
+7 ;clinic
SET ASDL=ASDL_$$PAD($$VAL^XBDIQ1(44,$PIECE(ASDS,U),.01),24)_" "
+8 DO FINDUSR
+9 ;made by
IF ASDU]""
SET ASDL=ASDL_$$PAD($$VAL^XBDIQ1(200,ASDU,.01),17)
+10 IF ASDU=""
SET ASDL=ASDL_$$PAD("??",17)
+11 ;appt made dt
IF ASDM]""
SET ASDL=ASDL_" "_$$FMTE^XLFDT(ASDM)
+12 IF ASDM=""
SET ASDL=ASDL_" ??"
+13 SET ASDLN=$GET(ASDLN)+1
SET ASDNUM=$GET(ASDNUM)+1
+14 SET ^TMP("ASDAMB",$JOB,ASDLN,0)=$JUSTIFY(ASDNUM,2)_". "_ASDL
+15 SET ^TMP("ASDAMB",$JOB,"IDX",ASDLN,ASDNUM)=DFN_U_+ASDS_U_ASDX
End DoDot:1
+16 SET VALMCNT=+$GET(ASDLN)
+17 QUIT
+18 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ASDBDT,ASDEDT,ASDA,ASDLN,ASDM,ASDNUM,ASDU,ASDX,AGE,SEX,DFN
+2 KILL SDC,SDIFN,SDP,SDPP,SDS,SDSTAT,SSN,VALMY,ORX
+3 KILL VALMBCK,VALMCNT,VALMHDR
+4 QUIT
+5 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
RETURN ; -- reset variables for return to lt
+1 DO TERM^VALM0
SET VALMBCK="R"
QUIT
+2 ;
GETAPPT ; -- select appt from listing
+1 DO FULL^VALM1
+2 SET ASDA=""
+3 DO EN^VALM2(XQORNOD(0),"OS")
+4 IF '$DATA(VALMY)
QUIT
+5 SET X=$ORDER(VALMY(0))
+6 SET Y=0
FOR
SET Y=$ORDER(^TMP("ASDAMB",$JOB,"IDX",Y))
IF Y=""
QUIT
IF ASDA]""
QUIT
Begin DoDot:1
+7 SET Z=$ORDER(^TMP("ASDAMB",$JOB,"IDX",Y,0))
+8 IF ^TMP("ASDAMB",$JOB,"IDX",Y,Z)=""
QUIT
+9 IF Z=X
SET ASDA=^TMP("ASDAMB",$JOB,"IDX",Y,Z)
End DoDot:1
+10 IF ASDA=""
QUIT
+11 SET DFN=$PIECE(ASDA,U)
SET SDIFN=$PIECE(ASDA,U,2)
SET SDA=$PIECE(ASDA,U,3)
+12 QUIT
+13 ;
VA ;EP; called by View Appt action
+1 SET (DFN,SDIFN,SDA)=""
DO GETAPPT
+2 IF DFN=""!(SDIFN="")!(SDA="")
Begin DoDot:1
+3 WRITE !,"Sorry data missing on this appointment!"
End DoDot:1
DO RETURN
QUIT
+4 DO ^XBCLS
DO P^SDCLK
DO PRTOPT^ASDVAR
DO RETURN
+5 QUIT
+6 ;
FINDUSR ; -- gets user and date made from file 44
+1 NEW X,Y
+2 SET Y=$PIECE(^DPT(DFN,"S",ASDX,0),U,18,19)
+3 IF +Y
SET ASDU=$PIECE(Y,U)
SET ASDM=$PIECE(Y,U,2)
QUIT
+4 KILL Y
SET X=0
FOR
SET X=$ORDER(^SC(+ASDS,"S",ASDX,1,X))
IF X=""!($DATA(Y))
QUIT
Begin DoDot:1
+5 IF +^SC(+ASDS,"S",ASDX,1,X,0)'=DFN
QUIT
+6 SET Y=$PIECE(^SC(+ASDS,"S",ASDX,1,X,0),U,6,7)
End DoDot:1
+7 SET ASDU=$PIECE($GET(Y),U)
SET ASDM=$PIECE($GET(Y),U,2)
+8 QUIT
+9 ;
PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
+1 QUIT $EXTRACT(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
