- 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
