SDAPICO1 ;ALB/MJK - API - Common Check-Out Processing;04 MAR 1993 10:00 am
;;5.3;Scheduling;**27,1015**;08/13/93;Build 21
;
CLASS(SDOE) ; -- file classification data
IF '$D(@SDROOT@("CLASSIFICATION")) G CLASSQ
N SDCLOEY,I,SDCTIS,SDCTS,SDVAL,SDCTVAL,SDCT,SDCT0,SDCTI,SDCTAB,SDACT
; -- find class required for this encounter
D CLASK^SDCO2(SDOE,.SDCLOEY)
;
; -- get class abbreviations
S SDCTI=0 F S SDCTI=$O(^SD(409.41,SDCTI)) Q:'SDCTI S SDCTAB($P(^(SDCTI,0),U,7))=SDCTI
;
; -- process deletions
IF $D(SDCLOEY),$D(@SDROOT@("CLASSIFICATION","DELETE")) D
. S SDCT=""
. F S SDCT=$O(@SDROOT@("CLASSIFICATION","DELETE",SDCT)) Q:SDCT="" D
.. ; -- valid class
.. S SDCTI=$$VALID(SDCT,.SDCTAB) Q:'SDCTI
.. ; -- delete co completion date ; delete class entry ; send warning
.. D COMDT^SDCODEL(SDOE),DEL^SDAPICO(SDOE,409.42,SDCTI),ERRFILE^SDAPIER(1045)
;
; -- warning if class data not required but passed
IF '$D(SDCLOEY),$D(@SDROOT@("CLASSIFICATION","ADD"))!($D(@SDROOT@("CLASSIFICATION","CHANGE"))) D ERRFILE^SDAPIER(1040) G CLASSQ
;
F SDACT="ADD","CHANGE" D
. S SDCT=""
. F S SDCT=$O(@SDROOT@("CLASSIFICATION",SDACT,SDCT)) Q:SDCT="" D
.. S SDVAL=@SDROOT@("CLASSIFICATION",SDACT,SDCT)
.. ; -- valid class abbrev passed
.. S SDCTI=$$VALID(SDCT,.SDCTAB) Q:'SDCTI
.. ; -- vaild format for class value passed
.. S SDCT0=$G(^SD(409.41,SDCTI,0))
.. IF '$$CHKVAL(SDCT0,.SDVAL) D ERRFILE^SDAPIER(1044,$P(SDCT0,U)_U_SDVAL) Q
.. S SDCTVAL(SDCTI)=SDVAL
.. ; -- if change to sc class then delete c/o process date & send warning
.. IF SDCTI=3,$G(SDCLOEY(3)),$P(SDCLOEY(3),U,2)]"",SDCTVAL(3)'=$P(SDCLOEY(3),U,2) D COMDT^SDCODEL(SDOE),ERRFILE^SDAPIER(1046)
;
; -- get required sequence to file class (ie. force sc to be 1st)
S SDCTIS=$$SEQ^SDCO21
F SDCTS=1:1 S SDCTI=+$P(SDCTIS,",",SDCTS) Q:'SDCTI!($D(SDCOQUIT)) D
. ; -- check to see if specific class is needed
. IF $D(SDCTVAL(SDCTI)),'$D(SDCLOEY(SDCTI)) D ERRFILE^SDAPIER(1047,$P($G(^SD(409.41,SDCTI,0)),U,7)) Q
. ; process specific class
. IF $D(SDCLOEY(SDCTI)) D
.. D ONE(SDCTI,SDCLOEY(SDCTI),SDOE,$G(SDCTVAL(SDCTI)))
.. ; -- if service connected class do consistency checks
.. IF SDCTI=3 F I=1,2,4 D SC^SDCO21(I,SDOE,"",.SDCLOEY)
CLASSQ Q
;
VALID(SDCT,SDCTAB) ; -- warning if not a valid class passed
N SDCTI
S SDCTI=+$G(SDCTAB(SDCT))
IF 'SDCTI D ERRFILE^SDAPIER(1041,SDCT)
Q SDCTI
;
ONE(SDCTI,SDATA,SDOE,SDVAL) ;Process One Classification at a time
; Input -- SDCTI Outpatient Classification Type IEN
; SDATA Null or 409.42 IEN^Internal Value^1=n/a^1=unedt
; SDOE Outpatient Encounter file IEN
; Output -- <none>
;
N SDCT0,DIK,DA
S SDCT0=$G(^SD(409.41,SDCTI,0)) G ONEQ:SDCT0']""
; -- no longer applicable
IF SDATA,$P(SDATA,"^",3) D G ONEQ
. N DIK,DA
. S DA=+SDATA,DIK="^SDD(409.42," D ^DIK
. D ERRFILE^SDAPIER(1042,$P(SDCT0,U))
; -- uneditable
IF SDATA,$P(SDATA,"^",4) D ERRFILE^SDAPIER(1043,$P(SDCT0,U)) G ONEQ
; -- file data
IF SDVAL]"" D FILE^SDCO20(+SDATA,SDVAL)
ONEQ Q
;
CHKVAL(SDCT0,SDVAL) ; -- validate classification value and convert
N Y,SDTYPE
S SDTYPE=$P(SDCT0,U,3),Y=0
IF SDTYPE="Y",SDVAL="Y"!(SDVAL="N") S Y=1,SDVAL=$S(SDVAL="Y":1,1:0)
IF SDTYPE="N",SDVAL=+SDVAL S Y=1
Q Y
;
SDAPICO1 ;ALB/MJK - API - Common Check-Out Processing;04 MAR 1993 10:00 am
+1 ;;5.3;Scheduling;**27,1015**;08/13/93;Build 21
+2 ;
CLASS(SDOE) ; -- file classification data
+1 IF '$DATA(@SDROOT@("CLASSIFICATION"))
GOTO CLASSQ
+2 NEW SDCLOEY,I,SDCTIS,SDCTS,SDVAL,SDCTVAL,SDCT,SDCT0,SDCTI,SDCTAB,SDACT
+3 ; -- find class required for this encounter
+4 DO CLASK^SDCO2(SDOE,.SDCLOEY)
+5 ;
+6 ; -- get class abbreviations
+7 SET SDCTI=0
FOR
SET SDCTI=$ORDER(^SD(409.41,SDCTI))
IF 'SDCTI
QUIT
SET SDCTAB($PIECE(^(SDCTI,0),U,7))=SDCTI
+8 ;
+9 ; -- process deletions
+10 IF $DATA(SDCLOEY)
IF $DATA(@SDROOT@("CLASSIFICATION","DELETE"))
Begin DoDot:1
+11 SET SDCT=""
+12 FOR
SET SDCT=$ORDER(@SDROOT@("CLASSIFICATION","DELETE",SDCT))
IF SDCT=""
QUIT
Begin DoDot:2
+13 ; -- valid class
+14 SET SDCTI=$$VALID(SDCT,.SDCTAB)
IF 'SDCTI
QUIT
+15 ; -- delete co completion date ; delete class entry ; send warning
+16 DO COMDT^SDCODEL(SDOE)
DO DEL^SDAPICO(SDOE,409.42,SDCTI)
DO ERRFILE^SDAPIER(1045)
End DoDot:2
End DoDot:1
+17 ;
+18 ; -- warning if class data not required but passed
+19 IF '$DATA(SDCLOEY)
IF $DATA(@SDROOT@("CLASSIFICATION","ADD"))!($DATA(@SDROOT@("CLASSIFICATION","CHANGE")))
DO ERRFILE^SDAPIER(1040)
GOTO CLASSQ
+20 ;
+21 FOR SDACT="ADD","CHANGE"
Begin DoDot:1
+22 SET SDCT=""
+23 FOR
SET SDCT=$ORDER(@SDROOT@("CLASSIFICATION",SDACT,SDCT))
IF SDCT=""
QUIT
Begin DoDot:2
+24 SET SDVAL=@SDROOT@("CLASSIFICATION",SDACT,SDCT)
+25 ; -- valid class abbrev passed
+26 SET SDCTI=$$VALID(SDCT,.SDCTAB)
IF 'SDCTI
QUIT
+27 ; -- vaild format for class value passed
+28 SET SDCT0=$GET(^SD(409.41,SDCTI,0))
+29 IF '$$CHKVAL(SDCT0,.SDVAL)
DO ERRFILE^SDAPIER(1044,$PIECE(SDCT0,U)_U_SDVAL)
QUIT
+30 SET SDCTVAL(SDCTI)=SDVAL
+31 ; -- if change to sc class then delete c/o process date & send warning
+32 IF SDCTI=3
IF $GET(SDCLOEY(3))
IF $PIECE(SDCLOEY(3),U,2)]""
IF SDCTVAL(3)'=$PIECE(SDCLOEY(3),U,2)
DO COMDT^SDCODEL(SDOE)
DO ERRFILE^SDAPIER(1046)
End DoDot:2
End DoDot:1
+33 ;
+34 ; -- get required sequence to file class (ie. force sc to be 1st)
+35 SET SDCTIS=$$SEQ^SDCO21
+36 FOR SDCTS=1:1
SET SDCTI=+$PIECE(SDCTIS,",",SDCTS)
IF 'SDCTI!($DATA(SDCOQUIT))
QUIT
Begin DoDot:1
+37 ; -- check to see if specific class is needed
+38 IF $DATA(SDCTVAL(SDCTI))
IF '$DATA(SDCLOEY(SDCTI))
DO ERRFILE^SDAPIER(1047,$PIECE($GET(^SD(409.41,SDCTI,0)),U,7))
QUIT
+39 ; process specific class
+40 IF $DATA(SDCLOEY(SDCTI))
Begin DoDot:2
+41 DO ONE(SDCTI,SDCLOEY(SDCTI),SDOE,$GET(SDCTVAL(SDCTI)))
+42 ; -- if service connected class do consistency checks
+43 IF SDCTI=3
FOR I=1,2,4
DO SC^SDCO21(I,SDOE,"",.SDCLOEY)
End DoDot:2
End DoDot:1
CLASSQ QUIT
+1 ;
VALID(SDCT,SDCTAB) ; -- warning if not a valid class passed
+1 NEW SDCTI
+2 SET SDCTI=+$GET(SDCTAB(SDCT))
+3 IF 'SDCTI
DO ERRFILE^SDAPIER(1041,SDCT)
+4 QUIT SDCTI
+5 ;
ONE(SDCTI,SDATA,SDOE,SDVAL) ;Process One Classification at a time
+1 ; Input -- SDCTI Outpatient Classification Type IEN
+2 ; SDATA Null or 409.42 IEN^Internal Value^1=n/a^1=unedt
+3 ; SDOE Outpatient Encounter file IEN
+4 ; Output -- <none>
+5 ;
+6 NEW SDCT0,DIK,DA
+7 SET SDCT0=$GET(^SD(409.41,SDCTI,0))
IF SDCT0']""
GOTO ONEQ
+8 ; -- no longer applicable
+9 IF SDATA
IF $PIECE(SDATA,"^",3)
Begin DoDot:1
+10 NEW DIK,DA
+11 SET DA=+SDATA
SET DIK="^SDD(409.42,"
DO ^DIK
+12 DO ERRFILE^SDAPIER(1042,$PIECE(SDCT0,U))
End DoDot:1
GOTO ONEQ
+13 ; -- uneditable
+14 IF SDATA
IF $PIECE(SDATA,"^",4)
DO ERRFILE^SDAPIER(1043,$PIECE(SDCT0,U))
GOTO ONEQ
+15 ; -- file data
+16 IF SDVAL]""
DO FILE^SDCO20(+SDATA,SDVAL)
ONEQ QUIT
+1 ;
CHKVAL(SDCT0,SDVAL) ; -- validate classification value and convert
+1 NEW Y,SDTYPE
+2 SET SDTYPE=$PIECE(SDCT0,U,3)
SET Y=0
+3 IF SDTYPE="Y"
IF SDVAL="Y"!(SDVAL="N")
SET Y=1
SET SDVAL=$SELECT(SDVAL="Y":1,1:0)
+4 IF SDTYPE="N"
IF SDVAL=+SDVAL
SET Y=1
+5 QUIT Y
+6 ;
