- SDACS1 ; IHS/ADC/PDW/ENM - EXTERNAL PACKAGE CALL TO ADD STOP CODES &/OR PROCEDURES 12:30 ; [ 03/25/1999 11:48 AM ]
- ;;5.3;IHS SCHEDULING;**1015**;MAR 25, 1999;Build 21
- ;;MAS VERSION 5.0;
- ;Continued from SDACS0
- G:SDCTYPE="C" CPT S SDA=SDC K SDC S SDC=SDA
- F SDA=1:1 S SDB=+$P(SDC,"^",SDA) Q:'SDB S SDC(SDB)="",SDD=$O(^DIC(40.7,"C",SDB,0)) I $S('SDD:1,SDB=900:1,'$D(^DIC(40.7,+SDD,0)):1,1:$P(^(0),"^",3)&(SDATE'<$P(^(0),"^",3))) D INV K SDC(SDB) D ERR:"SB"[SDMSG
- DUPCHK I $D(SDC)=11,$D(^SDV("ADT",DFN,$P(SDATE,"."))) S SDFDT=^($P(SDATE,".")) I $D(^SDV(SDFDT,0)) F SDB=0:0 S SDB=$O(^SDV(SDFDT,"CS",SDB)) Q:SDB'>0 S SDA=+^(SDB,0),SDA=$P(^DIC(40.7,+SDA,0),"^",2) I $D(SDC(SDA)) K SDC(SDA)
- ;
- G:$D(SDC)'=11 CPT I '$D(^SDV("ADT",DFN,$P(SDATE,"."))) D ADD
- F SDA=0:0 S SDA=$O(SDC(SDA)) Q:SDA'>0!(SDSCCT'<15) S DIE="^SDV(",DA=SDFDT,DR="10///"_SDA,DR(2,409.51)="2////^S X=DUZ;5////^S X=SDAPTYP;11////^S X=1" D ^DIE S SDERR=0,SDCTR=SDCTR+1,SDSCCT=SDSCCT+1
- CPT G Q:SDCTYPE="S" S SDCPTCT=0
- S DIC=40.7,DIC(0)="QMZ",X=900 D ^DIC I Y'>0 G CLEAN
- S SD900=+Y,IJ=""
- F SDJ=0:0 S SDJ=$O(SDCPT(SDJ)) Q:SDJ=""!(SDCPTCT>6)!(SDSCCT'<15) S SDECPT=0 D CHECK S SDERR=SDERR_"^"_SDECPT I 'SDECPT D ADD:'$D(^SDV("ADT",DFN,$P(SDATE,"."))),FILE I +SDY>0 S SDCTR=SDCTR+1,SDCPTCT=SDCPTCT+1,SDSCCT=SDSCCT+1
- Q I SDCPTCT>6!(SDSCCT'<15) D EXCESS
- ;I SDCTR W:'$D(SDMSG) !,"*** ",SDCTR," Stop code(s) recorded in Scheduling module ***",! G CLEAN
- S SDERR=$S(SDERR[0:0,1:1)
- CLEAN K SD900,SDA,SDAPTYP,SDA1,SDB,SDCPT,SDCPTCT,SDCTR,SDD,SDECPT,SDEMSG,SDF,SDFDT,SDFLAG,SDJ,SDP,SDSCCT,SDVNODE,SDY,DA,DIC,DIE,DR,IJ,IX,J,VAEL,VAERR,X,Y K:SDMSG=0 SDMSG Q
- INV S SDEMSG="Invalid, duplicate or inactive stop code "_SDB_" - Not " Q
- CHECK S SDECPT=$S($P(SDCPT(SDJ),U)'=900:1,$P(SDCPT(SDJ),U,2)']"":1,'$D(^SC(+$P(SDCPT(SDJ),U,2),0)):1,$P(^(0),U,3)'="C":1,1:0) I SDECPT K SDCPT(SDJ) S SDEMSG="Invalid data contained in CPT string - not " D ERR:"CB"[SDMSG Q
- S $P(SDCPT(SDJ),"^",8)=""
- I $P(SDCPT(SDJ),"^",3,7)?."^" S SDECPT=1 K SDCPT(SDJ) S SDEMSG="No CPT codes in SDCPT array - not " D ERR:"CB"[SDMSG Q
- I $D(^SDV("ADT",DFN,$P(SDATE,"."))) S DA(1)=+^SDV("ADT",DFN,$P(SDATE,".")),IX=0 F IJ=0:1 S IX=$O(^SDV("AP",DA(1),IX)) Q:IX'>0!(IJ=6)
- I IJ S SDCPTCT=IJ I SDCPTCT>6 S SDECPT=1 Q
- S SDCPT=$P(SDCPT(SDJ),"^",1,2)
- F J=3:1:7 S Y=$P(SDCPT(SDJ),"^",J) I Y D CHK1 S:'SDECPT SDCPT=SDCPT_"^"_Y S SDECPT=0
- S SDCPT(SDJ)=SDCPT,SDCPT="" I $P(SDCPT(SDJ),"^",3)']"" S SDECPT=1
- Q ;Return to CPT+3
- CHK1 I $S('$D(^SD(409.72,+$O(^(+$O(^SD(409.72,"AIVDT",Y,(9999998-SDATE))),0)),0)):1,'$P(^(0),"^",5):1,1:0) S SDECPT=1,SDEMSG="Invalid or Inactive CPT code "_Y_" -not " D ERR:"CB"[SDMSG
- Q
- ERR W !,*7,SDEMSG,"recorded in Scheduling module" Q
- EXCESS S SDEMSG=$S(SDSCCT'<15:"Fifteen ",1:"Six '900' ")_"Stop Codes for this date on record - no more can be " D ERR:SDMSG'=0 Q
- ADD S SDFDT=$S($P(SDATE,".",2)]"":SDATE,1:SDATE+.08)
- LOCK L ^SDV(SDFDT):1 I '$T!$D(^SDV(SDFDT)) L S SDFDT=SDFDT+.00001 G LOCK
- K DD,DO S DIC="^SDV(",DIC(0)="L",(DINUM,X)=SDFDT,DIC("DR")="2////"_DFN_";3////"_SDIV D FILE^DICN K DINUM,DIC,DO S DA(1)=+^SDV("ADT",DFN,$P(SDATE,"."))
- Q
- FILE ;
- K DR,DO,DD S X=SD900,DIC(0)="LM",(DIC,DIE)="^SDV("_DA(1)_",""CS"","
- I '$D(^SDV(DA(1),"CS",0)) S ^SDV(DA(1),"CS",0)="^"_$P(^DD(409.5,10,0),"^",2)_"^^"
- D FILE^DICN S SDY=Y Q:+Y'>0
- ;DR="2////^S X=DUZ;3////^S X=$P(SDCPT(SDJ),U,2);5////^S X=SDAPTYP;21////^S X=$P(SDCPT(SDJ),U,3)"_$S($P(SDCPT(SDJ),U,4)]"":";22////^S X=$P(SDCPT(SDJ),U,4)",1:"")
- ;S DR=DR_$S($P(SDCPT(SDJ),U,5)]"":";23////^S X=$P(SDCPT(SDJ),U,5)",1:"")_$S($P(SDCPT(SDJ),U,6)]"":";24////^S X=$P(SDCPT(SDJ),U,6)",1:"")_$S($P(SDCPT(SDJ),U,7)]"":";25////^S X=$P(SDCPT(SDJ),U,7)",1:""),SDVNODE=DIE_DA_")"
- S (DA,SDA1)=DA(1),DR="[SDXACSE]",DIE="^SDV(",SDVNODE=DIE_DA_")"
- L SDVNODE:2 I $T D ^DIE L K DR,DQ,DE,DIC,X S DA(1)=SDA1,DA=+SDY Q
- W !,*7,"Another user is editing this entry.",!
- Q
- SDACS1 ; IHS/ADC/PDW/ENM - EXTERNAL PACKAGE CALL TO ADD STOP CODES &/OR PROCEDURES 12:30 ; [ 03/25/1999 11:48 AM ]
- +1 ;;5.3;IHS SCHEDULING;**1015**;MAR 25, 1999;Build 21
- +2 ;;MAS VERSION 5.0;
- +3 ;Continued from SDACS0
- +4 IF SDCTYPE="C"
- GOTO CPT
- SET SDA=SDC
- KILL SDC
- SET SDC=SDA
- +5 FOR SDA=1:1
- SET SDB=+$PIECE(SDC,"^",SDA)
- IF 'SDB
- QUIT
- SET SDC(SDB)=""
- SET SDD=$ORDER(^DIC(40.7,"C",SDB,0))
- IF $SELECT('SDD:1,SDB=900:1,'$DATA(^DIC(40.7,+SDD,0)):1,1:$PIECE(^(0),"^",3)&(SDATE'<$PIECE(^(0),"^",3)))
- DO INV
- KILL SDC(SDB)
- IF "SB"[SDMSG
- DO ERR
- DUPCHK IF $DATA(SDC)=11
- IF $DATA(^SDV("ADT",DFN,$PIECE(SDATE,".")))
- SET SDFDT=^($PIECE(SDATE,"."))
- IF $DATA(^SDV(SDFDT,0))
- FOR SDB=0:0
- SET SDB=$ORDER(^SDV(SDFDT,"CS",SDB))
- IF SDB'>0
- QUIT
- SET SDA=+^(SDB,0)
- SET SDA=$PIECE(^DIC(40.7,+SDA,0),"^",2)
- IF $DATA(SDC(SDA))
- KILL SDC(SDA)
- +1 ;
- +2 IF $DATA(SDC)'=11
- GOTO CPT
- IF '$DATA(^SDV("ADT",DFN,$PIECE(SDATE,".")))
- DO ADD
- +3 FOR SDA=0:0
- SET SDA=$ORDER(SDC(SDA))
- IF SDA'>0!(SDSCCT'<15)
- QUIT
- SET DIE="^SDV("
- SET DA=SDFDT
- SET DR="10///"_SDA
- SET DR(2,409.51)="2////^S X=DUZ;5////^S X=SDAPTYP;11////^S X=1"
- DO ^DIE
- SET SDERR=0
- SET SDCTR=SDCTR+1
- SET SDSCCT=SDSCCT+1
- CPT IF SDCTYPE="S"
- GOTO Q
- SET SDCPTCT=0
- +1 SET DIC=40.7
- SET DIC(0)="QMZ"
- SET X=900
- DO ^DIC
- IF Y'>0
- GOTO CLEAN
- +2 SET SD900=+Y
- SET IJ=""
- +3 FOR SDJ=0:0
- SET SDJ=$ORDER(SDCPT(SDJ))
- IF SDJ=""!(SDCPTCT>6)!(SDSCCT'<15)
- QUIT
- SET SDECPT=0
- DO CHECK
- SET SDERR=SDERR_"^"_SDECPT
- IF 'SDECPT
- IF '$DATA(^SDV("ADT",DFN,$PIECE(SDATE,".")))
- DO ADD
- DO FILE
- IF +SDY>0
- SET SDCTR=SDCTR+1
- SET SDCPTCT=SDCPTCT+1
- SET SDSCCT=SDSCCT+1
- Q IF SDCPTCT>6!(SDSCCT'<15)
- DO EXCESS
- +1 ;I SDCTR W:'$D(SDMSG) !,"*** ",SDCTR," Stop code(s) recorded in Scheduling module ***",! G CLEAN
- +2 SET SDERR=$SELECT(SDERR[0:0,1:1)
- CLEAN KILL SD900,SDA,SDAPTYP,SDA1,SDB,SDCPT,SDCPTCT,SDCTR,SDD,SDECPT,SDEMSG,SDF,SDFDT,SDFLAG,SDJ,SDP,SDSCCT,SDVNODE,SDY,DA,DIC,DIE,DR,IJ,IX,J,VAEL,VAERR,X,Y
- IF SDMSG=0
- KILL SDMSG
- QUIT
- INV SET SDEMSG="Invalid, duplicate or inactive stop code "_SDB_" - Not "
- QUIT
- CHECK SET SDECPT=$SELECT($PIECE(SDCPT(SDJ),U)'=900:1,$PIECE(SDCPT(SDJ),U,2)']"":1,'$DATA(^SC(+$PIECE(SDCPT(SDJ),U,2),0)):1,$PIECE(^(0),U,3)'="C":1,1:0)
- IF SDECPT
- KILL SDCPT(SDJ)
- SET SDEMSG="Invalid data contained in CPT string - not "
- IF "CB"[SDMSG
- DO ERR
- QUIT
- +1 SET $PIECE(SDCPT(SDJ),"^",8)=""
- +2 IF $PIECE(SDCPT(SDJ),"^",3,7)?."^"
- SET SDECPT=1
- KILL SDCPT(SDJ)
- SET SDEMSG="No CPT codes in SDCPT array - not "
- IF "CB"[SDMSG
- DO ERR
- QUIT
- +3 IF $DATA(^SDV("ADT",DFN,$PIECE(SDATE,".")))
- SET DA(1)=+^SDV("ADT",DFN,$PIECE(SDATE,"."))
- SET IX=0
- FOR IJ=0:1
- SET IX=$ORDER(^SDV("AP",DA(1),IX))
- IF IX'>0!(IJ=6)
- QUIT
- +4 IF IJ
- SET SDCPTCT=IJ
- IF SDCPTCT>6
- SET SDECPT=1
- QUIT
- +5 SET SDCPT=$PIECE(SDCPT(SDJ),"^",1,2)
- +6 FOR J=3:1:7
- SET Y=$PIECE(SDCPT(SDJ),"^",J)
- IF Y
- DO CHK1
- IF 'SDECPT
- SET SDCPT=SDCPT_"^"_Y
- SET SDECPT=0
- +7 SET SDCPT(SDJ)=SDCPT
- SET SDCPT=""
- IF $PIECE(SDCPT(SDJ),"^",3)']""
- SET SDECPT=1
- +8 ;Return to CPT+3
- QUIT
- CHK1 IF $SELECT('$DATA(^SD(409.72,+$ORDER(^(+$ORDER(^SD(409.72,"AIVDT",Y,(9999998-SDATE))),0)),0)):1,'$PIECE(^(0),"^",5):1,1:0)
- SET SDECPT=1
- SET SDEMSG="Invalid or Inactive CPT code "_Y_" -not "
- IF "CB"[SDMSG
- DO ERR
- +1 QUIT
- ERR WRITE !,*7,SDEMSG,"recorded in Scheduling module"
- QUIT
- EXCESS SET SDEMSG=$SELECT(SDSCCT'<15:"Fifteen ",1:"Six '900' ")_"Stop Codes for this date on record - no more can be "
- IF SDMSG'=0
- DO ERR
- QUIT
- ADD SET SDFDT=$SELECT($PIECE(SDATE,".",2)]"":SDATE,1:SDATE+.08)
- LOCK LOCK ^SDV(SDFDT):1
- IF '$TEST!$DATA(^SDV(SDFDT))
- LOCK
- SET SDFDT=SDFDT+.00001
- GOTO LOCK
- +1 KILL DD,DO
- SET DIC="^SDV("
- SET DIC(0)="L"
- SET (DINUM,X)=SDFDT
- SET DIC("DR")="2////"_DFN_";3////"_SDIV
- DO FILE^DICN
- KILL DINUM,DIC,DO
- SET DA(1)=+^SDV("ADT",DFN,$PIECE(SDATE,"."))
- +2 QUIT
- FILE ;
- +1 KILL DR,DO,DD
- SET X=SD900
- SET DIC(0)="LM"
- SET (DIC,DIE)="^SDV("_DA(1)_",""CS"","
- +2 IF '$DATA(^SDV(DA(1),"CS",0))
- SET ^SDV(DA(1),"CS",0)="^"_$PIECE(^DD(409.5,10,0),"^",2)_"^^"
- +3 DO FILE^DICN
- SET SDY=Y
- IF +Y'>0
- QUIT
- +4 ;DR="2////^S X=DUZ;3////^S X=$P(SDCPT(SDJ),U,2);5////^S X=SDAPTYP;21////^S X=$P(SDCPT(SDJ),U,3)"_$S($P(SDCPT(SDJ),U,4)]"":";22////^S X=$P(SDCPT(SDJ),U,4)",1:"")
- +5 ;S DR=DR_$S($P(SDCPT(SDJ),U,5)]"":";23////^S X=$P(SDCPT(SDJ),U,5)",1:"")_$S($P(SDCPT(SDJ),U,6)]"":";24////^S X=$P(SDCPT(SDJ),U,6)",1:"")_$S($P(SDCPT(SDJ),U,7)]"":";25////^S X=$P(SDCPT(SDJ),U,7)",1:""),SDVNODE=DIE_DA_")"
- +6 SET (DA,SDA1)=DA(1)
- SET DR="[SDXACSE]"
- SET DIE="^SDV("
- SET SDVNODE=DIE_DA_")"
- +7 LOCK SDVNODE:2
- IF $TEST
- DO ^DIE
- LOCK
- KILL DR,DQ,DE,DIC,X
- SET DA(1)=SDA1
- SET DA=+SDY
- QUIT
- +8 WRITE !,*7,"Another user is editing this entry.",!
- +9 QUIT
