ASDOI ; IHS/ADC/PDW/ENM - ADD/EDIT OTHER INFORMATION ; [ 09/30/2002 9:25 AM ]
;;5.0;IHS SCHEDULING;**8**;MAR 25, 1999
;IHS/ITSC/KMS, 09/30/2002 - Cache' compliancy.
;
S:'$D(DTIME) DTIME=300 D:'$D(DT) DT^SDUTL S HDT=DT,APL=""
RD S DIC="^DPT(",DIC(0)="AEQM",CNT=0 D ^DIC I X=U!(X="") G END
S DFN=+Y,NAME=$P(Y,U,2) W ! I $O(^DPT(DFN,"S",HDT))'>0 D NO G RD
S NDT=HDT,L=0
F J=1:1 S NDT=$O(^DPT(DFN,"S",NDT)) Q:'NDT D
. S X=$P(^DPT(DFN,"S",NDT,0),U,2) I $S(X="":1,X["I":1,1:0) D
.. D CHKSO S SC=+^DPT(DFN,"S",NDT,0),L=L+1 D FLEN
.. S Z(L)=NDT_U_SC_U_APL_U_COMMENT_U_ZL
I L'>0 D NO G RD
F ZZ=1:1:L D
. W !!,ZZ,") " S Y=$P($P(Z(ZZ),U,1),".",1)
. D DT^SDM0 S X=$P(Z(ZZ),U,1) X ^DD("FUNC",2,1)
. W " ",$J(X,8)," (",$P(Z(ZZ),U,3)," MINUTES) "
. W $P(^SC($P(Z(ZZ),U,2),0),U,1)," ",$P(Z(ZZ),U,4)
;
WH W !! K DIR S DIR(0)="NO^1:"_ZZ
S DIR("A")="ADD/EDIT OTHER INFO FOR WHICH NUMBERED APPOINTMENT"
S DIR("?")="Enter the number that corresponds to the appointment."
D ^DIR S APP=Y I $D(DIRUT) G RD
S SD=$P(Z(APP),U,1),SCX=$P(Z(APP),U,2),SDY=$P(Z(APP),U,5),CNT=CNT+1
D OTHER G RD
;
;
NO W !,"NO PENDING APPOINTMENTS",*7,*7,*7 Q
;
FLEN ; find appt multiple
I $D(^SC(SC,"S",NDT)) F ZL=0:0 S ZL=$O(^SC(SC,"S",NDT,1,ZL)) Q:'ZL I +^SC(SC,"S",NDT,1,ZL,0)=DFN S APL=$P(^SC(SC,"S",NDT,1,ZL,0),U,2) Q
Q
;
CHKSO ; -- check if tests scheduled
S COMMENT="",SDAPAV=^DPT(DFN,"S",NDT,0),SDANAM="LAB"_U_"XRAY"_U_"EKG"
F SDJ=3,4,5 D
. I $P(SDAPAV,U,SDJ)]"" D
.. S:$L(COMMENT) COMMENT=COMMENT_","
.. S COMMENT=COMMENT_$S(SDJ=3:"LAB",SDJ=4:"XRAY",1:"EKG")
.. S @($P(SDANAM,U,SDJ-2))=$P(SDAPAV,U,SDJ)
S:$L(COMMENT) COMMENT="("_COMMENT_" TEST SCHEDULED)"
Q
;
END K CNT,NDT,L,J,HDT,SC,SD,APL,COMMENT,Z,ZZ,APP,ZL,SDJ,X,%DT,DIC,DFN
K NAME,Y,POP,SDAPAV,SDTY,SDX,SDY,%,D,SCX Q
;
OTHER ; -- edits other info field
L +^SC(SCX,"S",SD):3 I '$T D Q
. W !,*7,"APPOINTMENT ENTRY LOCKED; TRY AGAIN SOON"
;IHS/ITSC/KMS, 09/30/2002, Added extra space " " after DO for Cache' compliance.
;I '$D(^SC(SCX,"S",SD,1,0)) D ;searhc/maw patch to add header
I '$D(^SC(SCX,"S",SD,1,0)) D ;searhc/maw patch to add header
. S ^SC(SCX,"S",SD,1,0)="^44.003PA^^" ;maw added
W ! S DIE="^SC("_SCX_",""S"","_SD_",1,",DA=SDY,DA(1)=SD,DA(2)=SCX
S DR="3T" D ^DIE L -^SC(SCX,"S",SD)
Q
ASDOI ; IHS/ADC/PDW/ENM - ADD/EDIT OTHER INFORMATION ; [ 09/30/2002 9:25 AM ]
+1 ;;5.0;IHS SCHEDULING;**8**;MAR 25, 1999
+2 ;IHS/ITSC/KMS, 09/30/2002 - Cache' compliancy.
+3 ;
+4 IF '$DATA(DTIME)
SET DTIME=300
IF '$DATA(DT)
DO DT^SDUTL
SET HDT=DT
SET APL=""
RD SET DIC="^DPT("
SET DIC(0)="AEQM"
SET CNT=0
DO ^DIC
IF X=U!(X="")
GOTO END
+1 SET DFN=+Y
SET NAME=$PIECE(Y,U,2)
WRITE !
IF $ORDER(^DPT(DFN,"S",HDT))'>0
DO NO
GOTO RD
+2 SET NDT=HDT
SET L=0
+3 FOR J=1:1
SET NDT=$ORDER(^DPT(DFN,"S",NDT))
IF 'NDT
QUIT
Begin DoDot:1
+4 SET X=$PIECE(^DPT(DFN,"S",NDT,0),U,2)
IF $SELECT(X="":1,X["I":1,1:0)
Begin DoDot:2
+5 DO CHKSO
SET SC=+^DPT(DFN,"S",NDT,0)
SET L=L+1
DO FLEN
+6 SET Z(L)=NDT_U_SC_U_APL_U_COMMENT_U_ZL
End DoDot:2
End DoDot:1
+7 IF L'>0
DO NO
GOTO RD
+8 FOR ZZ=1:1:L
Begin DoDot:1
+9 WRITE !!,ZZ,") "
SET Y=$PIECE($PIECE(Z(ZZ),U,1),".",1)
+10 DO DT^SDM0
SET X=$PIECE(Z(ZZ),U,1)
XECUTE ^DD("FUNC",2,1)
+11 WRITE " ",$JUSTIFY(X,8)," (",$PIECE(Z(ZZ),U,3)," MINUTES) "
+12 WRITE $PIECE(^SC($PIECE(Z(ZZ),U,2),0),U,1)," ",$PIECE(Z(ZZ),U,4)
End DoDot:1
+13 ;
WH WRITE !!
KILL DIR
SET DIR(0)="NO^1:"_ZZ
+1 SET DIR("A")="ADD/EDIT OTHER INFO FOR WHICH NUMBERED APPOINTMENT"
+2 SET DIR("?")="Enter the number that corresponds to the appointment."
+3 DO ^DIR
SET APP=Y
IF $DATA(DIRUT)
GOTO RD
+4 SET SD=$PIECE(Z(APP),U,1)
SET SCX=$PIECE(Z(APP),U,2)
SET SDY=$PIECE(Z(APP),U,5)
SET CNT=CNT+1
+5 DO OTHER
GOTO RD
+6 ;
+7 ;
NO WRITE !,"NO PENDING APPOINTMENTS",*7,*7,*7
QUIT
+1 ;
FLEN ; find appt multiple
+1 IF $DATA(^SC(SC,"S",NDT))
FOR ZL=0:0
SET ZL=$ORDER(^SC(SC,"S",NDT,1,ZL))
IF 'ZL
QUIT
IF +^SC(SC,"S",NDT,1,ZL,0)=DFN
SET APL=$PIECE(^SC(SC,"S",NDT,1,ZL,0),U,2)
QUIT
+2 QUIT
+3 ;
CHKSO ; -- check if tests scheduled
+1 SET COMMENT=""
SET SDAPAV=^DPT(DFN,"S",NDT,0)
SET SDANAM="LAB"_U_"XRAY"_U_"EKG"
+2 FOR SDJ=3,4,5
Begin DoDot:1
+3 IF $PIECE(SDAPAV,U,SDJ)]""
Begin DoDot:2
+4 IF $LENGTH(COMMENT)
SET COMMENT=COMMENT_","
+5 SET COMMENT=COMMENT_$SELECT(SDJ=3:"LAB",SDJ=4:"XRAY",1:"EKG")
+6 SET @($PIECE(SDANAM,U,SDJ-2))=$PIECE(SDAPAV,U,SDJ)
End DoDot:2
End DoDot:1
+7 IF $LENGTH(COMMENT)
SET COMMENT="("_COMMENT_" TEST SCHEDULED)"
+8 QUIT
+9 ;
END KILL CNT,NDT,L,J,HDT,SC,SD,APL,COMMENT,Z,ZZ,APP,ZL,SDJ,X,%DT,DIC,DFN
+1 KILL NAME,Y,POP,SDAPAV,SDTY,SDX,SDY,%,D,SCX
QUIT
+2 ;
OTHER ; -- edits other info field
+1 LOCK +^SC(SCX,"S",SD):3
IF '$TEST
Begin DoDot:1
+2 WRITE !,*7,"APPOINTMENT ENTRY LOCKED; TRY AGAIN SOON"
End DoDot:1
QUIT
+3 ;IHS/ITSC/KMS, 09/30/2002, Added extra space " " after DO for Cache' compliance.
+4 ;I '$D(^SC(SCX,"S",SD,1,0)) D ;searhc/maw patch to add header
+5 ;searhc/maw patch to add header
IF '$DATA(^SC(SCX,"S",SD,1,0))
Begin DoDot:1
+6 ;maw added
SET ^SC(SCX,"S",SD,1,0)="^44.003PA^^"
End DoDot:1
+7 WRITE !
SET DIE="^SC("_SCX_",""S"","_SD_",1,"
SET DA=SDY
SET DA(1)=SD
SET DA(2)=SCX
+8 SET DR="3T"
DO ^DIE
LOCK -^SC(SCX,"S",SD)
+9 QUIT
