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
