- 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)
