- 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
