SDAM1 ;MJK/ALB - Appt Mgt (Patient);Apr 23 1999
;;5.3;PIMS;**149,155,193,189,445,478,466,1003,1004,1005,1014,1015,1016**;JUN 30, 2012;Build 20
;
;IHS/ANMC/LJF 4/11/2002 removed check for VA parameter
;IHS/ITSC/LJF 06/17/2005 PATCH 1003 allow appt threshold to be set to zero
;IHS/OIT/LJF 07/28/2005 PATCH 1004 added call to display waiting list info
;IHS/OIT/LJF 12/29/2005 PATCH 1005 added "Walk In" to status display
; removed code for status to blink if checked in by ancillary service
;ihs/cmi/maw 02/02/2012 patch 1014, changed set of appointment mode to silent fileman call
;
INIT ; -- get init pat appt data
; input: DFN := ifn of pat
; output: ^TMP("SDAM" := appt array
;IHS/ITSC/LJF 6/17/2005 PATCH 1003
;S X=$P($G(^DG(43,1,"SCLR")),U,12),SDPRD=$S(X:X,1:2)
S X=$P($G(^DG(43,1,"SCLR")),U,12),SDPRD=$S(X]"":X,1:2)
S X1=DT,X2=-SDPRD D C^%DTC S SDBEG=X
S X1=DT,X2=999 D C^%DTC S SDEND=X
D CHGCAP^VALM("NAME","Clinic")
S X="ALL" D LIST^SDAM
Q
;
BLD ; -- scan apts
N SDAMDD,SDNAME,SDMAX,SDLARGE,DFN,SDCL,BL,XC,XW,AC,AW,TC,TW,NC,NW,SC,SW,SDT,CC,CW,CN,CNPAT,CNSTLNK,CSTAT ; done for speed see INIT
D INIT^SDAM10
S DFN=SDFN
F SDT=SDBEG:0 S SDT=$O(^DPT(DFN,"S",SDT)) Q:'SDT!($P(SDT,".",1)>SDEND) I $D(^(SDT,0)) S SDATA=^(0),SDCL=+SDATA,SDNAME=$P($G(^SC(SDCL,0)),U) D K:CNSTLNK="" CNSTLNK D BLD1 ;SD/478
.S CNSTLNK="",CN=0 F S CN=$O(^SC(SDCL,"S",SDT,1,CN)) Q:'+CN S CNPAT=$P($G(^SC(SDCL,"S",SDT,1,CN,0)),U) I CNPAT=DFN S CNSTLNK=$P($G(^SC(SDCL,"S",SDT,1,CN,"CONS")),U),CSTAT="" S:CNSTLNK'="" CSTAT=$P($G(^GMR(123,CNSTLNK,0)),U,12) Q ;SD/478
;
I $O(^TMP("SDAM",$J,0)) D WLDIS^BSDAM(DFN) ;IHS/OIT/LJF 7/28/2005 PATCH 1004
;
D NUL^SDAM10,LARGE^SDAM10:$D(SDLARGE)
S $P(^TMP("SDAM",$J,0),U,4)=VALMCNT
Q
;
BLD1 ; -- build array
N SDX,X,Y,Y1,SDSTAT,SDELIG
S SDSTAT=$$STATUS(DFN,SDT,SDCL,SDATA,$S($D(SDDA):SDDA,1:""))
G BLD1Q:'$$CHK(DFN,SDT,SDCL,SDATA,.SDAMLIST,SDSTAT)
;; Changes for GAF enhancement
S SDGAFREQ=" "
S SDELIG=$$ELSTAT^SDUTL2(DFN)
I $$MHCLIN^SDUTL2(SDCL),'($$COLLAT^SDUTL2(SDELIG)!$P(SDATA,U,11)) D
.S SDGAF=$$NEWGAF^SDUTL2(DFN),SDGAFST=$P(SDGAF,"^")
.S:SDGAFST SDGAFREQ="*"
S SDACNT=SDACNT+1,X="",$P(X," ",VALMWD+1)=""
W:(SDACNT#10)=0 "."
I SDACNT=SDMAX,$P(SDT,".")'=SDEND S SDEND=$P(SDT,"."),SDLARGE=""
S X=SDGAFREQ_$E(X,2,AC-1)_$E(SDACNT_BL,1,AW)_$E(X,AC+AW+1,VALMWD)
S X=$E(X,1,NC-1)_$E($$LOWER(SDNAME)_BL,1,NW)_$E(X,NC+NW+1,VALMWD)
S X=$E(X,1,XC-1)_$E($$FMTE^XLFDT(SDT,"5Z")_BL,1,XW)_$E(X,XC+XW+1,VALMWD) ;to make date field work for SD*5.3*189 - uses FM List Template
S:'$D(CSTAT) CSTAT="" ;SD/478
S X=$E(X,1,CC-1)_$E($S((CSTAT=1!(CSTAT=2)!(CSTAT=13)):" ",$G(CNSTLNK):"Consult",1:" ")_BL,1,CW)_$E(X,CC+CW+1,VALMWD) K CNSTLNK,CSTAT ;SD/478
S Y=$P(SDSTAT,";",3)
;
I (Y["CHECKED"),$P(SDATA,U,7)=4,('$P(SDSTAT,";",6)) S Y="WALK IN/"_Y ;IHS/OIT/LJF 12/29/2005 PATCH 1005
;
I Y'["FUTURE" S X=$E(X,1,SC-1)_$E($$LOWER(Y)_BL,1,SW)_$E(X,SC+SW+1,VALMWD)
I Y["FUTURE" S X=$E(X,1,SC-1)_$E($$LOWER(Y)_$$ANC_BL,1,SW+TW+1)
S Y1=$S($P(SDSTAT,";",5):$P(SDSTAT,";",5),1:$P(SDSTAT,";",4)),Y1=$S($P(Y1,".")=DT:$$TIME($P(Y1,".",2)),1:"")
S:Y1]"" X=$E(X,1,TC-1)_$E(Y1_BL,1,TW)_$E(X,TC+TW+1,VALMWD)
D SET(X)
I $D(SDAMBOLD(DFN,SDT,SDCL)) D FLDCTRL^VALM10(VALMCNT,"STAT",IOINHI,IOINORM),FLDCTRL^VALM10(VALMCNT,"TIME",IOINHI,IOINORM)
S ^TMP("SDAMIDX",$J,SDACNT)=VALMCNT_U_DFN_U_SDT_U_SDCL_U_$S($D(SDDA):SDDA,1:"")
BLD1Q Q
;
ANC() ; -- set ancillary info
N I,Y,C
S Y="",C=0
F I=3:1:5 I $P(SDATA,U,I)]"" S Y=Y_" "_$P("^^Lab^XRay^EKG",U,I)_"@"_$$TIME($P($P(SDATA,U,I),".",2)),C=C+1 Q:C=2
I Y]"" S Y="/"_$E(Y,2,99)
Q Y
;
SET(X) ;
S VALMCNT=VALMCNT+1,^TMP("SDAM",$J,VALMCNT,0)=X
S:SDACNT ^TMP("SDAM",$J,"IDX",VALMCNT,SDACNT)=""
Q
;
CHK(DFN,SDT,SDCL,SDATA,SDAMLIST,SDSTAT,SDDA) ; -- does appt meet criteria
; input: DFN := ifn of pat.
; SDT := appt d/t
; SDCL := ifn of clinic
; SDATA := 0th node of pat appt entry
; SDAMLIST := list definition
; SDSTAT := appt status data from $$STATUS call
; SDDA := ifn for ^SC(clinic,"S",date,1,ifn) {optional}
; output: [returned] := meets criteria for list [0 - no | 1 - yes ]
;
S Y=0
I $D(SDAMLIST(+SDSTAT)) S Y=1 G CHKQ
I $P(SDAMLIST,U)="ALL" S Y=1
I $P(SDAMLIST,U)="CHECKED IN" I $P(SDSTAT,";",3)="ACT REQ/CHECKED IN" S Y=1 ; - SD*5.3*445
CHKQ I Y,$D(SDAMLIST("SCR")) X SDAMLIST("SCR") S Y=$T
Q Y
;
STATUS(DFN,SDT,SDCL,SDATA,SDDA) ; -- return appt status
; input: DFN := ifn of pat.
; SDT := appt d/t
; SDCL := ifn of clinic
; SDATA := 0th node of pat appt entry
; SDDA := ifn for ^SC(clinic,"S",date,1,ifn) {optional}
; output: [returned] := appt status ifn ^ status name ^ print status ^
; check in d/t ^ check out d/t ^ adm mvt ifn
;
;S = status ; C = ci/co indicator ; Y = 'C' node ; P = print status
N S,C,Y,P,VADMVT,VAINDT
;
; -- get data for evaluation
S:'$G(SDDA) SDDA=+$$FIND^SDAM2(DFN,SDT,SDCL)
S Y=$G(^SC(SDCL,"S",SDT,1,SDDA,"C"))
;
; -- set initial status value ; non-count clinic?
S S=$S($P(SDATA,"^",2)]"":$P($P($P(^DD(2.98,3,0),"^",3),$P(SDATA,"^",2)_":",2),";"),$P($G(^SC(SDCL,0)),U,17)="Y":"NON-COUNT",1:"")
;
; -- inpatient?
S VAINDT=SDT D ADM^VADPT2
I S["INPATIENT",$S('VADMVT:1,'$P(^DG(43,1,0),U,21):0,1:$P($G(^DIC(42,+$P($G(^DGPM(VADMVT,0)),U,6),0)),U,3)="D") S S=""
;
; -- determine ci/co indicator
I Y="",SDT<DT,$D(^SCE("ADFN",DFN,SDT)) S POP=0 D CHKENC G:POP STAT1 ;SD*567
K POP
S C=$S($P(Y,"^",3):"CHECKED OUT",Y:"CHECKED IN",S]"":"",SDT>(DT+.2359):"FUTURE",1:"NO ACTION TAKEN") S:S="" S=C
I S="NO ACTION TAKEN",$P(SDT,".")=DT,C'["CHECKED" S C="TODAY"
STAT1 ; -- $$REQ & $$COCMP in SDM1A not used for speed
K POP
;I S="CHECKED OUT"!(S="CHECKED IN"),SDT'<$P(^DG(43,1,"SCLR"),U,23),'$P($G(^SCE(+$P(SDATA,U,20),0)),U,7) S S="NO ACTION TAKEN" ;IHS/ANMC/LJF 4/11/2002
;
; -- determine print status
S P=$S(S=C!(C=""):S,1:"")
I P="" D
.I S["INPATIENT",$P($G(^SC(SDCL,0)),U,17)'="Y",$P($G(^SCE(+$P(SDATA,U,20),0)),U,7)="" S P=$P(S," ")_"/ACT REQ" Q
.I S="NO ACTION TAKEN",C="CHECKED OUT"!(C="CHECKED IN") S P="ACT REQ/"_C Q
.;next line for testing
.;I S="CANCELLED BY CLINIC" I $P(Y,U,1)'="" I $P(Y,U,3)="" S P=S Q
.S P=$S(S="NO ACTION TAKEN":S,1:$P(S," "))_"/"_C
I S["INPATIENT",C="" D
.I SDT>(DT+.2359) S P=$P(S," ")_"/FUTURE" Q
.S P=$P(S," ")_"/NO ACT TAKN"
;
STATUSQ Q +$O(^SD(409.63,"AC",S,0))_";"_S_";"_P_";"_$P(Y,"^")_";"_$P(Y,"^",3)_";"_+VADMVT
;
CHKENC ;SD*567 grab status from outpatient encounter for purged appts
N SNODE,SDIEN
S SDIEN=""
S SDIEN=$O(^SCE("ADFN",DFN,SDT,SDIEN)) Q:'SDIEN
S SNODE=$G(^SCE(SDIEN,0))
Q:SNODE=""
Q:'$D(^SD(409.63,$P(SNODE,U,12),0))
S C=$P(^SD(409.63,$P(SNODE,U,12),0),U,1),POP=1
S:S="" S=C
Q
;
LOWER(X) ; convert to lowercase ; same as LOWER^VALM1 ; here for speed
N Y,C,I
S Y=$E(X)_$TR($E(X,2,999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ@","abcdefghijklmnopqrstuvwxyz ")
F C=" ",",","/" S I=0 F S I=$F(Y,C,I) Q:'I S Y=$E(Y,1,I-1)_$TR($E(Y,I),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$E(Y,I+1,999)
Q Y
;
TIME(X) ; -- format time only := hr:min
Q $E(X_"0000",1,2)_":"_$E(X_"0000",3,4)
SDAM1 ;MJK/ALB - Appt Mgt (Patient);Apr 23 1999
+1 ;;5.3;PIMS;**149,155,193,189,445,478,466,1003,1004,1005,1014,1015,1016**;JUN 30, 2012;Build 20
+2 ;
+3 ;IHS/ANMC/LJF 4/11/2002 removed check for VA parameter
+4 ;IHS/ITSC/LJF 06/17/2005 PATCH 1003 allow appt threshold to be set to zero
+5 ;IHS/OIT/LJF 07/28/2005 PATCH 1004 added call to display waiting list info
+6 ;IHS/OIT/LJF 12/29/2005 PATCH 1005 added "Walk In" to status display
+7 ; removed code for status to blink if checked in by ancillary service
+8 ;ihs/cmi/maw 02/02/2012 patch 1014, changed set of appointment mode to silent fileman call
+9 ;
INIT ; -- get init pat appt data
+1 ; input: DFN := ifn of pat
+2 ; output: ^TMP("SDAM" := appt array
+3 ;IHS/ITSC/LJF 6/17/2005 PATCH 1003
+4 ;S X=$P($G(^DG(43,1,"SCLR")),U,12),SDPRD=$S(X:X,1:2)
+5 SET X=$PIECE($GET(^DG(43,1,"SCLR")),U,12)
SET SDPRD=$SELECT(X]"":X,1:2)
+6 SET X1=DT
SET X2=-SDPRD
DO C^%DTC
SET SDBEG=X
+7 SET X1=DT
SET X2=999
DO C^%DTC
SET SDEND=X
+8 DO CHGCAP^VALM("NAME","Clinic")
+9 SET X="ALL"
DO LIST^SDAM
+10 QUIT
+11 ;
BLD ; -- scan apts
+1 ; done for speed see INIT
NEW SDAMDD,SDNAME,SDMAX,SDLARGE,DFN,SDCL,BL,XC,XW,AC,AW,TC,TW,NC,NW,SC,SW,SDT,CC,CW,CN,CNPAT,CNSTLNK,CSTAT
+2 DO INIT^SDAM10
+3 SET DFN=SDFN
+4 ;SD/478
FOR SDT=SDBEG:0
SET SDT=$ORDER(^DPT(DFN,"S",SDT))
IF 'SDT!($PIECE(SDT,".",1)>SDEND)
QUIT
IF $DATA(^(SDT,0))
SET SDATA=^(0)
SET SDCL=+SDATA
SET SDNAME=$PIECE($GET(^SC(SDCL,0)),U)
Begin DoDot:1
+5 ;SD/478
SET CNSTLNK=""
SET CN=0
FOR
SET CN=$ORDER(^SC(SDCL,"S",SDT,1,CN))
IF '+CN
QUIT
SET CNPAT=$PIECE($GET(^SC(SDCL,"S",SDT,1,CN,0)),U)
IF CNPAT=DFN
SET CNSTLNK=$PIECE($GET(^SC(SDCL,"S",SDT,1,CN,"CONS")),U)
SET CSTAT=""
IF CNSTLNK'=""
SET CSTAT=$PIECE($GET(^GMR(123,CNSTLNK,0)),U,12)
QUIT
End DoDot:1
IF CNSTLNK=""
KILL CNSTLNK
DO BLD1
+6 ;
+7 ;IHS/OIT/LJF 7/28/2005 PATCH 1004
IF $ORDER(^TMP("SDAM",$JOB,0))
DO WLDIS^BSDAM(DFN)
+8 ;
+9 DO NUL^SDAM10
IF $DATA(SDLARGE)
DO LARGE^SDAM10
+10 SET $PIECE(^TMP("SDAM",$JOB,0),U,4)=VALMCNT
+11 QUIT
+12 ;
BLD1 ; -- build array
+1 NEW SDX,X,Y,Y1,SDSTAT,SDELIG
+2 SET SDSTAT=$$STATUS(DFN,SDT,SDCL,SDATA,$SELECT($DATA(SDDA):SDDA,1:""))
+3 IF '$$CHK(DFN,SDT,SDCL,SDATA,.SDAMLIST,SDSTAT)
GOTO BLD1Q
+4 ;; Changes for GAF enhancement
+5 SET SDGAFREQ=" "
+6 SET SDELIG=$$ELSTAT^SDUTL2(DFN)
+7 IF $$MHCLIN^SDUTL2(SDCL)
IF '($$COLLAT^SDUTL2(SDELIG)!$PIECE(SDATA,U,11))
Begin DoDot:1
+8 SET SDGAF=$$NEWGAF^SDUTL2(DFN)
SET SDGAFST=$PIECE(SDGAF,"^")
+9 IF SDGAFST
SET SDGAFREQ="*"
End DoDot:1
+10 SET SDACNT=SDACNT+1
SET X=""
SET $PIECE(X," ",VALMWD+1)=""
+11 IF (SDACNT#10)=0
WRITE "."
+12 IF SDACNT=SDMAX
IF $PIECE(SDT,".")'=SDEND
SET SDEND=$PIECE(SDT,".")
SET SDLARGE=""
+13 SET X=SDGAFREQ_$EXTRACT(X,2,AC-1)_$EXTRACT(SDACNT_BL,1,AW)_$EXTRACT(X,AC+AW+1,VALMWD)
+14 SET X=$EXTRACT(X,1,NC-1)_$EXTRACT($$LOWER(SDNAME)_BL,1,NW)_$EXTRACT(X,NC+NW+1,VALMWD)
+15 ;to make date field work for SD*5.3*189 - uses FM List Template
SET X=$EXTRACT(X,1,XC-1)_$EXTRACT($$FMTE^XLFDT(SDT,"5Z")_BL,1,XW)_$EXTRACT(X,XC+XW+1,VALMWD)
+16 ;SD/478
IF '$DATA(CSTAT)
SET CSTAT=""
+17 ;SD/478
SET X=$EXTRACT(X,1,CC-1)_$EXTRACT($SELECT((CSTAT=1!(CSTAT=2)!(CSTAT=13)):" ",$GET(CNSTLNK):"Consult",1:" ")_BL,1,CW)_$EXTRACT(X,CC+CW+1,VALMWD)
KILL CNSTLNK,CSTAT
+18 SET Y=$PIECE(SDSTAT,";",3)
+19 ;
+20 ;IHS/OIT/LJF 12/29/2005 PATCH 1005
IF (Y["CHECKED")
IF $PIECE(SDATA,U,7)=4
IF ('$PIECE(SDSTAT,";",6))
SET Y="WALK IN/"_Y
+21 ;
+22 IF Y'["FUTURE"
SET X=$EXTRACT(X,1,SC-1)_$EXTRACT($$LOWER(Y)_BL,1,SW)_$EXTRACT(X,SC+SW+1,VALMWD)
+23 IF Y["FUTURE"
SET X=$EXTRACT(X,1,SC-1)_$EXTRACT($$LOWER(Y)_$$ANC_BL,1,SW+TW+1)
+24 SET Y1=$SELECT($PIECE(SDSTAT,";",5):$PIECE(SDSTAT,";",5),1:$PIECE(SDSTAT,";",4))
SET Y1=$SELECT($PIECE(Y1,".")=DT:$$TIME($PIECE(Y1,".",2)),1:"")
+25 IF Y1]""
SET X=$EXTRACT(X,1,TC-1)_$EXTRACT(Y1_BL,1,TW)_$EXTRACT(X,TC+TW+1,VALMWD)
+26 DO SET(X)
+27 IF $DATA(SDAMBOLD(DFN,SDT,SDCL))
DO FLDCTRL^VALM10(VALMCNT,"STAT",IOINHI,IOINORM)
DO FLDCTRL^VALM10(VALMCNT,"TIME",IOINHI,IOINORM)
+28 SET ^TMP("SDAMIDX",$JOB,SDACNT)=VALMCNT_U_DFN_U_SDT_U_SDCL_U_$SELECT($DATA(SDDA):SDDA,1:"")
BLD1Q QUIT
+1 ;
ANC() ; -- set ancillary info
+1 NEW I,Y,C
+2 SET Y=""
SET C=0
+3 FOR I=3:1:5
IF $PIECE(SDATA,U,I)]""
SET Y=Y_" "_$PIECE("^^Lab^XRay^EKG",U,I)_"@"_$$TIME($PIECE($PIECE(SDATA,U,I),".",2))
SET C=C+1
IF C=2
QUIT
+4 IF Y]""
SET Y="/"_$EXTRACT(Y,2,99)
+5 QUIT Y
+6 ;
SET(X) ;
+1 SET VALMCNT=VALMCNT+1
SET ^TMP("SDAM",$JOB,VALMCNT,0)=X
+2 IF SDACNT
SET ^TMP("SDAM",$JOB,"IDX",VALMCNT,SDACNT)=""
+3 QUIT
+4 ;
CHK(DFN,SDT,SDCL,SDATA,SDAMLIST,SDSTAT,SDDA) ; -- does appt meet criteria
+1 ; input: DFN := ifn of pat.
+2 ; SDT := appt d/t
+3 ; SDCL := ifn of clinic
+4 ; SDATA := 0th node of pat appt entry
+5 ; SDAMLIST := list definition
+6 ; SDSTAT := appt status data from $$STATUS call
+7 ; SDDA := ifn for ^SC(clinic,"S",date,1,ifn) {optional}
+8 ; output: [returned] := meets criteria for list [0 - no | 1 - yes ]
+9 ;
+10 SET Y=0
+11 IF $DATA(SDAMLIST(+SDSTAT))
SET Y=1
GOTO CHKQ
+12 IF $PIECE(SDAMLIST,U)="ALL"
SET Y=1
+13 ; - SD*5.3*445
IF $PIECE(SDAMLIST,U)="CHECKED IN"
IF $PIECE(SDSTAT,";",3)="ACT REQ/CHECKED IN"
SET Y=1
CHKQ IF Y
IF $DATA(SDAMLIST("SCR"))
XECUTE SDAMLIST("SCR")
SET Y=$TEST
+1 QUIT Y
+2 ;
STATUS(DFN,SDT,SDCL,SDATA,SDDA) ; -- return appt status
+1 ; input: DFN := ifn of pat.
+2 ; SDT := appt d/t
+3 ; SDCL := ifn of clinic
+4 ; SDATA := 0th node of pat appt entry
+5 ; SDDA := ifn for ^SC(clinic,"S",date,1,ifn) {optional}
+6 ; output: [returned] := appt status ifn ^ status name ^ print status ^
+7 ; check in d/t ^ check out d/t ^ adm mvt ifn
+8 ;
+9 ;S = status ; C = ci/co indicator ; Y = 'C' node ; P = print status
+10 NEW S,C,Y,P,VADMVT,VAINDT
+11 ;
+12 ; -- get data for evaluation
+13 IF '$GET(SDDA)
SET SDDA=+$$FIND^SDAM2(DFN,SDT,SDCL)
+14 SET Y=$GET(^SC(SDCL,"S",SDT,1,SDDA,"C"))
+15 ;
+16 ; -- set initial status value ; non-count clinic?
+17 SET S=$SELECT($PIECE(SDATA,"^",2)]"":$PIECE($PIECE($PIECE(^DD(2.98,3,0),"^",3),$PIECE(SDATA,"^",2)_":",2),";"),$PIECE($GET(^SC(SDCL,0)),U,17)="Y":"NON-COUNT",1:"")
+18 ;
+19 ; -- inpatient?
+20 SET VAINDT=SDT
DO ADM^VADPT2
+21 IF S["INPATIENT"
IF $SELECT('VADMVT:1,'$PIECE(^DG(43,1,0),U,21):0,1:$PIECE($GET(^DIC(42,+$PIECE($GET(^DGPM(VADMVT,0)),U,6),0)),U,3)="D")
SET S=""
+22 ;
+23 ; -- determine ci/co indicator
+24 ;SD*567
IF Y=""
IF SDT<DT
IF $DATA(^SCE("ADFN",DFN,SDT))
SET POP=0
DO CHKENC
IF POP
GOTO STAT1
+25 KILL POP
+26 SET C=$SELECT($PIECE(Y,"^",3):"CHECKED OUT",Y:"CHECKED IN",S]"":"",SDT>(DT+.2359):"FUTURE",1:"NO ACTION TAKEN")
IF S=""
SET S=C
+27 IF S="NO ACTION TAKEN"
IF $PIECE(SDT,".")=DT
IF C'["CHECKED"
SET C="TODAY"
STAT1 ; -- $$REQ & $$COCMP in SDM1A not used for speed
+1 KILL POP
+2 ;I S="CHECKED OUT"!(S="CHECKED IN"),SDT'<$P(^DG(43,1,"SCLR"),U,23),'$P($G(^SCE(+$P(SDATA,U,20),0)),U,7) S S="NO ACTION TAKEN" ;IHS/ANMC/LJF 4/11/2002
+3 ;
+4 ; -- determine print status
+5 SET P=$SELECT(S=C!(C=""):S,1:"")
+6 IF P=""
Begin DoDot:1
+7 IF S["INPATIENT"
IF $PIECE($GET(^SC(SDCL,0)),U,17)'="Y"
IF $PIECE($GET(^SCE(+$PIECE(SDATA,U,20),0)),U,7)=""
SET P=$PIECE(S," ")_"/ACT REQ"
QUIT
+8 IF S="NO ACTION TAKEN"
IF C="CHECKED OUT"!(C="CHECKED IN")
SET P="ACT REQ/"_C
QUIT
+9 ;next line for testing
+10 ;I S="CANCELLED BY CLINIC" I $P(Y,U,1)'="" I $P(Y,U,3)="" S P=S Q
+11 SET P=$SELECT(S="NO ACTION TAKEN":S,1:$PIECE(S," "))_"/"_C
End DoDot:1
+12 IF S["INPATIENT"
IF C=""
Begin DoDot:1
+13 IF SDT>(DT+.2359)
SET P=$PIECE(S," ")_"/FUTURE"
QUIT
+14 SET P=$PIECE(S," ")_"/NO ACT TAKN"
End DoDot:1
+15 ;
STATUSQ QUIT +$ORDER(^SD(409.63,"AC",S,0))_";"_S_";"_P_";"_$PIECE(Y,"^")_";"_$PIECE(Y,"^",3)_";"_+VADMVT
+1 ;
CHKENC ;SD*567 grab status from outpatient encounter for purged appts
+1 NEW SNODE,SDIEN
+2 SET SDIEN=""
+3 SET SDIEN=$ORDER(^SCE("ADFN",DFN,SDT,SDIEN))
IF 'SDIEN
QUIT
+4 SET SNODE=$GET(^SCE(SDIEN,0))
+5 IF SNODE=""
QUIT
+6 IF '$DATA(^SD(409.63,$PIECE(SNODE,U,12),0))
QUIT
+7 SET C=$PIECE(^SD(409.63,$PIECE(SNODE,U,12),0),U,1)
SET POP=1
+8 IF S=""
SET S=C
+9 QUIT
+10 ;
LOWER(X) ; convert to lowercase ; same as LOWER^VALM1 ; here for speed
+1 NEW Y,C,I
+2 SET Y=$EXTRACT(X)_$TRANSLATE($EXTRACT(X,2,999),"ABCDEFGHIJKLMNOPQRSTUVWXYZ@","abcdefghijklmnopqrstuvwxyz ")
+3 FOR C=" ",",","/"
SET I=0
FOR
SET I=$FIND(Y,C,I)
IF 'I
QUIT
SET Y=$EXTRACT(Y,1,I-1)_$TRANSLATE($EXTRACT(Y,I),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$EXTRACT(Y,I+1,999)
+4 QUIT Y
+5 ;
TIME(X) ; -- format time only := hr:min
+1 QUIT $EXTRACT(X_"0000",1,2)_":"_$EXTRACT(X_"0000",3,4)
