APCDGHVD.m

APCDGHVD ; IHS/CMI/LAB - GET HISTORICAL VISIT DATE ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;

 ; This routines is called from templates to edit and create

 ; a visit.

 S APCDGHVD="",APCDTERR=0,APCDTMG1="Enter a Date betwen the Patient's DOB and Today.",APCDTMG2="Can be imprecise (e.g. 1975 or 3/1975 or 3/4/1975).  Time optional."

READ I '$D(APCDTPRM) W !,"Enter Date of Historical ",APCDTHT,":  " D SBRS

 I $D(APCDTPRM) W !,APCDTPRM D SBRS

 I $D(DTOUT)!($D(DLOUT))!($D(DUOUT)) S APCDTERR=1 G XIT

 I $D(DQOUT) W !,APCDBEEP,APCDTMG1,!,APCDTMG2 G READ

 S APCDTX=Y

EDIT ;

 S %DT="PT",X=APCDTX D ^%DT S APCDTX=Y I Y=-1 W !!,APCDBEEP,APCDTMG1,!,APCDTMG2,! G READ

 ;beginning of Y2K fix.  Changed 6,999 to 6,7

 ;S:$E(APCDTX,6,999)="00" APCDTX=$E(APCDTX,1,5)_"01"_$E(APCDTX,8,9999) S:$E(APCDTX,4,5)="00" APCDTX=$E(APCDTX,1,3)_"01"_$E(APCDTX,6,7) S:APCDTX'["." APCDTX=APCDTX_".12"

 S:$E(APCDTX,6,7)="00" APCDTX=$E(APCDTX,1,5)_"01" S:$E(APCDTX,4,5)="00" APCDTX=$E(APCDTX,1,3)_"01"_$E(APCDTX,6,7) S:APCDTX'["." APCDTX=APCDTX_".12" ;Y2000

 ;end Y2K

 S X=APCDTX

 X $P(^DD(9000010,.01,0),"^",5,99) I '$D(X) W !!,APCDBEEP,APCDTMG1,!,APCDTMG2,! S APCDTX="" G READ

 S APCDVLDT=APCDTX,APCDLOOK=""

 S APCDTPAT=$G(APCDPAT),APCDTDAT=$G(APCDDATE),APCDTTYP=$G(APCDTYPE),APCDTCAT=$G(APCDCAT),APCDTLOC=$G(APCDLOC),APCDTVST=$G(APCDVSIT)

 D ^APCDVLK

 K APCDCLN

 I APCDGHVD="^" S APCDTERR=1 G XIT

 I APCDLOOK="" S APCDLOOK=""""_APCDTX_"""",APCDTFA=1

XIT ;

 K Y,X,APCDVLDT,APCDTMG1,APCDTMG2,APCDGHVD

 Q

SBRS ;

 K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT

 R Y:DTIME I '$T W $C(7) R Y:5 G SBRS:Y="." I '$T S (DTOUT,DFOUT)="" Q

 S:Y="" DLOUT="" S:Y="^" (DUOUT,Y)=""

 I Y?1"?".E!(Y["^") S DQOUT=$S(Y="??":2,1:1),Y="" Q

 ;I Y]"",$D(DUZ)#2,$D(^VA(200,DUZ,200)),Y=$P(^(200),U,7) S (Y,DFOUT)="" ;IHS/CMI/LAB - commented out

 Q

APCDGHVD  ; IHS/CMI/LAB - GET HISTORICAL VISIT DATE ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

 +3       ; This routines is called from templates to edit and create

 +4       ; a visit.

 +5        SET APCDGHVD=""

           SET APCDTERR=0

           SET APCDTMG1="Enter a Date betwen the Patient's DOB and Today."

           SET APCDTMG2="Can be imprecise (e.g. 1975 or 3/1975 or 3/4/1975).  Time optional."

READ       IF '$DATA(APCDTPRM)

               WRITE !,"Enter Date of Historical ",APCDTHT,":  "

               DO SBRS

 +1        IF $DATA(APCDTPRM)

               WRITE !,APCDTPRM

               DO SBRS

 +2        IF $DATA(DTOUT)!($DATA(DLOUT))!($DATA(DUOUT))

               SET APCDTERR=1

               GOTO XIT

 +3        IF $DATA(DQOUT)

               WRITE !,APCDBEEP,APCDTMG1,!,APCDTMG2

               GOTO READ

 +4        SET APCDTX=Y

EDIT      ;

 +1        SET %DT="PT"

           SET X=APCDTX

           DO ^%DT

           SET APCDTX=Y

           IF Y=-1

               WRITE !!,APCDBEEP,APCDTMG1,!,APCDTMG2,!

               GOTO READ

 +2       ;beginning of Y2K fix.  Changed 6,999 to 6,7

 +3       ;S:$E(APCDTX,6,999)="00" APCDTX=$E(APCDTX,1,5)_"01"_$E(APCDTX,8,9999) S:$E(APCDTX,4,5)="00" APCDTX=$E(APCDTX,1,3)_"01"_$E(APCDTX,6,7) S:APCDTX'["." APCDTX=APCDTX_".12"

 +4       ;Y2000

           IF $EXTRACT(APCDTX,6,7)="00"

               SET APCDTX=$EXTRACT(APCDTX,1,5)_"01"

           IF $EXTRACT(APCDTX,4,5)="00"

               SET APCDTX=$EXTRACT(APCDTX,1,3)_"01"_$EXTRACT(APCDTX,6,7)

           IF APCDTX'["."

               SET APCDTX=APCDTX_".12"

 +5       ;end Y2K

 +6        SET X=APCDTX

 +7        XECUTE $PIECE(^DD(9000010,.01,0),"^",5,99)

           IF '$DATA(X)

               WRITE !!,APCDBEEP,APCDTMG1,!,APCDTMG2,!

               SET APCDTX=""

               GOTO READ

 +8        SET APCDVLDT=APCDTX

           SET APCDLOOK=""

 +9        SET APCDTPAT=$GET(APCDPAT)

           SET APCDTDAT=$GET(APCDDATE)

           SET APCDTTYP=$GET(APCDTYPE)

           SET APCDTCAT=$GET(APCDCAT)

           SET APCDTLOC=$GET(APCDLOC)

           SET APCDTVST=$GET(APCDVSIT)

 +10       DO ^APCDVLK

 +11       KILL APCDCLN

 +12       IF APCDGHVD="^"

               SET APCDTERR=1

               GOTO XIT

 +13       IF APCDLOOK=""

               SET APCDLOOK=""""_APCDTX_""""

               SET APCDTFA=1

XIT       ;

 +1        KILL Y,X,APCDVLDT,APCDTMG1,APCDTMG2,APCDGHVD

 +2        QUIT 

SBRS      ;

 +1        KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT

 +2        READ Y:DTIME

           IF '$TEST

               WRITE $CHAR(7)

               READ Y:5

               IF Y="."

                   GOTO SBRS

               IF '$TEST

                   SET (DTOUT,DFOUT)=""

                   QUIT 

 +3        IF Y=""

               SET DLOUT=""

           IF Y="^"

               SET (DUOUT,Y)=""

 +4        IF Y?1"?".E!(Y["^")

               SET DQOUT=$SELECT(Y="??":2,1:1)

               SET Y=""

               QUIT 

 +5       ;I Y]"",$D(DUZ)#2,$D(^VA(200,DUZ,200)),Y=$P(^(200),U,7) S (Y,DFOUT)="" ;IHS/CMI/LAB - commented out

 +6        QUIT