AMHVRL2.m

AMHVRL2 ; IHS/CMI/LAB - DEMO/APPTS ACTION ;

 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 ;

SENDPAT  ;EP - called from protocol

 D FULL^VALM1

 S AMHVSAV=DFN

 S Y=DFN D ^AUPNPAT

 I '$$PKGCK^AMHVU("LROW","LAB VERSION 5.2") Q

 Q:'$G(DFN)

 I '$D(^AMHSITE(DUZ(2),14,"B",DUZ)) W !!,$C(7),$C(7),"I am sorry, you do not have access to this option.  See your supervisor." H 2 Q

 D SENDPAT^LRORD

 S DFN=AMHVSAV

 D RESET^AMHVRL

 Q

APPT(DFN) ;EP; called by AMHV APPT protocol

 NEW AUPNPAT,AUPNSEX,AUPNDOB,AUPNDOD

 S AMHVSAV=DFN

 S Y=DFN D ^AUPNPAT

 I $T(EN1^SDAM)]"" Q:'$G(DFN)  S SDY=DFN_";DPT(" D EN1^SDAM S (DFN,AMHPAT)=AMHVSAV Q

 I '$$PKGCK^AMHVU("ASDI","SCHEDULING VERSION 5.0") Q

 Q:'$G(DFN)

 ;

MENU ; -- menu of scheduling actions

 NEW DIR,I,DIRUT

 D ^XBCLS

 D MSG^AMHVU($$SP(10)_"SCHEDULING ACTIONS AVAILABLE",2,2,0)

 S DIR(0)="NO^1:4",DIR("A")="Select Action by number"

 F I=1:1:4 S DIR("A",I)=$P($T(CHOICE+I),";;",2)

 D ^DIR K DIR Q:$D(DIRUT)  D @Y G MENU

 ;

1 ; -- make appt

 NEW SDPEP,SDMM,DIC

 D MSG^AMHVU($$SP(10)_"Make Appointment for "_$$NAME,2,2,0)

 S SDPEP=1,SDMM=0 D EN1^SDM S DFN=AMHVSAV

 Q

 ;

2 ; -- cancel appt

 NEW SDPEP,DA,NAME

 D MSG^AMHVU($$SP(10)_"Cancel Appointment for "_$$NAME,2,2,0)

 S SDPEP=1,DA=DFN,NAME=$$NAME D EN^SDCNP S DFN=AMHVSAV

 Q

 ;

3 ; -- check-in/walkin

 NEW SDPEP,DIV

 S SDPEP=1 D PAT2^ASDI,RETURN^AMHVU S DFN=AMHVSAV

 Q

 ;

4 ; -- display appts

 NEW SDPEP,HDT,APL,SDRG,SDEDT,OTH,SDEND,DA,NAME

 S SDPEP=1,NAME=$$NAME,HDT=DT,(APL,SDEDT,OTH)="",(SDRG,SDEND)=0

 S DA=DFN D RD1^SDDPA,RETURN^AMHVU S DFN=AMHVSAV

 Q

 ;

HDR ; -- print header

 NEW X

 S X=IOUON_$$PAD($$SP(10)_"APPOINTMENTS"_$$SP(8)_$$NOW,77)_IOUOFF

 D MSG^AMHVU(X,1,0,0)

 D MSG^AMHVU($$SP(10)_$$CONFID^AMHVU("Patient"),0,0,0)

 D MSG^AMHVU($$NAME_$$SP(5)_$$HRCN,1,0,0)

 D MSG^AMHVU($$REPEAT^XLFSTR("_",80),1,1,0)

 Q

 ;

NOW() ; -- returns readable now

 Q $$FMTE^XLFDT($$NOW^XLFDT,1)

 ;

NAME() ; -- returns printable name

 Q $$VAL^XBDIQ1(9000001,DFN,.01)

 ;

HRCN() ; -- returns chart # for this facility

 Q "#"_$P($G(^AUPNPAT(DFN,41,+DUZ(2),0)),U,2)

 ;

PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data

 Q $E(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)

 ;

SP(NUM) ; -- SUBRTN to pad spaces

 Q $$PAD(" ",NUM)

 ;

PIMS ;

 Q:'$G(DFN)

 D EN1^SDAM

 Q

CHOICE ;;

 ;; 1. MAKE APPOINTMENT

 ;; 2. CANCEL APPOINTMENT

 ;; 3. CHECK-IN/WALK-IN/CHART REQUEST

 ;; 4. DISPLAY APPOINTMENT

AMHVRL2   ; IHS/CMI/LAB - DEMO/APPTS ACTION ;

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 +2       ;

SENDPAT   ;EP - called from protocol

 +1        DO FULL^VALM1

 +2        SET AMHVSAV=DFN

 +3        SET Y=DFN

           DO ^AUPNPAT

 +4        IF '$$PKGCK^AMHVU("LROW","LAB VERSION 5.2")

               QUIT 

 +5        IF '$GET(DFN)

               QUIT 

 +6        IF '$DATA(^AMHSITE(DUZ(2),14,"B",DUZ))

               WRITE !!,$CHAR(7),$CHAR(7),"I am sorry, you do not have access to this option.  See your supervisor."

               HANG 2

               QUIT 

 +7        DO SENDPAT^LRORD

 +8        SET DFN=AMHVSAV

 +9        DO RESET^AMHVRL

 +10       QUIT 

APPT(DFN) ;EP; called by AMHV APPT protocol

 +1        NEW AUPNPAT,AUPNSEX,AUPNDOB,AUPNDOD

 +2        SET AMHVSAV=DFN

 +3        SET Y=DFN

           DO ^AUPNPAT

 +4        IF $TEXT(EN1^SDAM)]""

               IF '$GET(DFN)

                   QUIT 

               SET SDY=DFN_";DPT("

               DO EN1^SDAM

               SET (DFN,AMHPAT)=AMHVSAV

               QUIT 

 +5        IF '$$PKGCK^AMHVU("ASDI","SCHEDULING VERSION 5.0")

               QUIT 

 +6        IF '$GET(DFN)

               QUIT 

 +7       ;

MENU      ; -- menu of scheduling actions

 +1        NEW DIR,I,DIRUT

 +2        DO ^XBCLS

 +3        DO MSG^AMHVU($$SP(10)_"SCHEDULING ACTIONS AVAILABLE",2,2,0)

 +4        SET DIR(0)="NO^1:4"

           SET DIR("A")="Select Action by number"

 +5        FOR I=1:1:4

               SET DIR("A",I)=$PIECE($TEXT(CHOICE+I),";;",2)

 +6        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               QUIT 

           DO @Y

           GOTO MENU

 +7       ;

1         ; -- make appt

 +1        NEW SDPEP,SDMM,DIC

 +2        DO MSG^AMHVU($$SP(10)_"Make Appointment for "_$$NAME,2,2,0)

 +3        SET SDPEP=1

           SET SDMM=0

           DO EN1^SDM

           SET DFN=AMHVSAV

 +4        QUIT 

 +5       ;

2         ; -- cancel appt

 +1        NEW SDPEP,DA,NAME

 +2        DO MSG^AMHVU($$SP(10)_"Cancel Appointment for "_$$NAME,2,2,0)

 +3        SET SDPEP=1

           SET DA=DFN

           SET NAME=$$NAME

           DO EN^SDCNP

           SET DFN=AMHVSAV

 +4        QUIT 

 +5       ;

3         ; -- check-in/walkin

 +1        NEW SDPEP,DIV

 +2        SET SDPEP=1

           DO PAT2^ASDI

           DO RETURN^AMHVU

           SET DFN=AMHVSAV

 +3        QUIT 

 +4       ;

4         ; -- display appts

 +1        NEW SDPEP,HDT,APL,SDRG,SDEDT,OTH,SDEND,DA,NAME

 +2        SET SDPEP=1

           SET NAME=$$NAME

           SET HDT=DT

           SET (APL,SDEDT,OTH)=""

           SET (SDRG,SDEND)=0

 +3        SET DA=DFN

           DO RD1^SDDPA

           DO RETURN^AMHVU

           SET DFN=AMHVSAV

 +4        QUIT 

 +5       ;

HDR       ; -- print header

 +1        NEW X

 +2        SET X=IOUON_$$PAD($$SP(10)_"APPOINTMENTS"_$$SP(8)_$$NOW,77)_IOUOFF

 +3        DO MSG^AMHVU(X,1,0,0)

 +4        DO MSG^AMHVU($$SP(10)_$$CONFID^AMHVU("Patient"),0,0,0)

 +5        DO MSG^AMHVU($$NAME_$$SP(5)_$$HRCN,1,0,0)

 +6        DO MSG^AMHVU($$REPEAT^XLFSTR("_",80),1,1,0)

 +7        QUIT 

 +8       ;

NOW()     ; -- returns readable now

 +1        QUIT $$FMTE^XLFDT($$NOW^XLFDT,1)

 +2       ;

NAME()    ; -- returns printable name

 +1        QUIT $$VAL^XBDIQ1(9000001,DFN,.01)

 +2       ;

HRCN()    ; -- returns chart # for this facility

 +1        QUIT "#"_$PIECE($GET(^AUPNPAT(DFN,41,+DUZ(2),0)),U,2)

 +2       ;

PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data

 +1        QUIT $EXTRACT(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)

 +2       ;

SP(NUM)   ; -- SUBRTN to pad spaces

 +1        QUIT $$PAD(" ",NUM)

 +2       ;

PIMS      ;

 +1        IF '$GET(DFN)

               QUIT 

 +2        DO EN1^SDAM

 +3        QUIT 

CHOICE    ;;

 +1       ;; 1. MAKE APPOINTMENT

 +2       ;; 2. CANCEL APPOINTMENT

 +3       ;; 3. CHECK-IN/WALK-IN/CHART REQUEST

 +4       ;; 4. DISPLAY APPOINTMENT