- PSJ0103 ;BIR/JLC - Check for Non-Standard Schedules ;01-MAR-04
- ;;5.0; INPATIENT MEDICATIONS ;**103**;16 DEC 97
- ;
- ;Reference to ^PS(50.606 is supported by DBIA# 2174.
- ;Reference to ^PS(50.7 is supported by DBIA# 2180.
- ;Reference to ^PS(51.1 is supported by DBIA# 2177.
- ;Reference to ^PS(52.6 is supported by DBIA# 1231.
- ;Reference to ^PS(55 is supported by DBIA# 2191.
- ;
- ENNV ;
- I $G(DUZ)="" W !,"Your DUZ is not defined." Q
- W !,"NUMBER OF DAYS: 365// " R X:DTIME I X="^"!'$T Q
- I X="" S X=365
- I X'?1.3N!(X<0)!(X?1.2"?") W:X'?1.2"?" $C(7) W "Must be number, 1-999 days." G ENNV
- S PSJDAYS=X K ZTSAVE,ZTSK S ZTSAVE("PSJDAYS")="",ZTRTN="ENQN^PSJ0103",ZTDESC="Schedule Search",ZTIO="" D ^%ZTLOAD
- W !!,"The check of Pharmacy orders is",$S($D(ZTSK):"",1:" NOT")," queued",!
- I $D(ZTSK) W " (to start NOW).",!!,"YOU WILL RECEIVE A MAILMAN MESSAGE WHEN TASK #"_ZTSK_" HAS COMPLETED."
- Q
- ENQN ;
- N PSJBEG,PSJPDFN,PSJORD,PSJSCHD,CREAT,EXPR,OCNT,PSJND0,PSJND2,X,A,S1,S2,OK
- D NOW^%DTC S CREAT=$E(%,1,7),EXPR=$$FMADD^XLFDT(CREAT,30,0,0,0) K ^XTMP("PSJSC") S PSJSCHD=0
- F S PSJSCHD=$O(^PS(51.1,"AC","PSJ",PSJSCHD)) Q:PSJSCHD="" I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","DAN51.1",PSJSCHD)=""
- S %H=$H-PSJDAYS D YMD^%DTC S PSJBEG=X F S PSJBEG=$O(^PS(55,"AUDS",PSJBEG)) Q:PSJBEG="" S PSJPDFN=0 F S PSJPDFN=$O(^PS(55,"AUDS",PSJBEG,PSJPDFN)) Q:'PSJPDFN D
- . S PSJORD=0 F S PSJORD=$O(^PS(55,"AUDS",PSJBEG,PSJPDFN,PSJORD)) Q:'PSJORD D
- .. S PSJND2=$G(^PS(55,PSJPDFN,5,PSJORD,2)),PSJND0=^(0),PSJSCHD=$P(PSJND2,"^") D
- ... S ^XTMP("PSJSC","ALL",PSJSCHD)=""
- ... I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","DAN",PSJSCHD)="" I $P(PSJND0,"^",9)="A" S ^XTMP("PSJSC","DANON",PSJSCHD,PSJPDFN,"UD",PSJORD)=$P(PSJND0,"^",2)_"^"_$P(^PS(55,PSJPDFN,5,PSJORD,.2),"^",1,2)
- ... I $D(^PS(51.1,"AC","PSJ",PSJSCHD)) Q
- ... D MISC(PSJSCHD) Q:OK
- ... S ^XTMP("PSJSC","NSS",PSJSCHD)="" I $P(PSJND0,"^",9)="A" S ^XTMP("PSJSC","NSSON",PSJSCHD,PSJPDFN,"UD",PSJORD)=$P(PSJND0,"^",2)_"^"_$P(^PS(55,PSJPDFN,5,PSJORD,.2),"^",1,2)
- S %H=$H-PSJDAYS D YMD^%DTC S PSJBEG=X F S PSJBEG=$O(^PS(55,"AIVS",PSJBEG)) Q:PSJBEG="" S PSJPDFN=0 F S PSJPDFN=$O(^PS(55,"AIVS",PSJBEG,PSJPDFN)) Q:'PSJPDFN D
- . S PSJORD=0 F S PSJORD=$O(^PS(55,"AIVS",PSJBEG,PSJPDFN,PSJORD)) Q:'PSJORD D
- .. S PSJND0=$G(^PS(55,PSJPDFN,"IV",PSJORD,0)),PSJSCHD=$P(PSJND0,"^",9) I PSJSCHD]"" D
- ... S ^XTMP("PSJSC","ALL",PSJSCHD)=""
- ... S ITEM="" S A=$O(^PS(55,PSJPDFN,"IV",PSJORD,"AD",0)) I A S ITEM="A^"_$P(^(A,0),"^")_"^"_$P(^(0),"^",2)
- ... I ITEM="" S A=$O(^PS(55,PSJPDFN,"IV",PSJORD,"SOL",0)) I A S ITEM="S^"_$P(^(A,0),"^")_"^"_$P(^(0),"^",2)
- ... I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","DAN",PSJSCHD)="" I $P(PSJND0,"^",17)="A" S ^XTMP("PSJSC","DANON",PSJSCHD,PSJPDFN,"IV",PSJORD)=$P(PSJND0,"^",6)_"^"_ITEM
- ... I $D(^PS(51.1,"AC","PSJ",PSJSCHD)) Q
- ... D MISC(PSJSCHD) Q:OK
- ... S ^XTMP("PSJSC","NSS",PSJSCHD)="" I $P(PSJND0,"^",17)="A" S ^XTMP("PSJSC","NSSON",PSJSCHD,PSJPDFN,"IV",PSJORD)=$P(PSJND0,"^",6)_"^"_ITEM
- S S1=0 F S S1=$O(^PS(52.6,S1)) Q:'S1 D
- . S A=$G(^PS(52.6,S1,0)),PSJSCHD=$P(A,"^",5) Q:PSJSCHD=""
- . I '$D(^PS(51.1,"AC","PSJ",PSJSCHD)) D MISC(PSJSCHD) I 'OK S ^XTMP("PSJSC","QC","NSS",$P(A,"^"))=""
- . I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","QC","DAN",$P(A,"^"))=""
- . S S2=0 F S S2=$O(^PS(52.6,S1,1,S2)) Q:'S2 D
- .. S A=$G(^PS(52.6,S1,1,S2,0)),PSJSCHD=$P(A,"^",5) Q:PSJSCHD=""
- .. I '$D(^PS(51.1,"AC","PSJ",PSJSCHD)) D MISC(PSJSCHD) I 'OK S ^XTMP("PSJSC","QC","NSS",$P(A,"^"))=""
- .. I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","QC","DAN",$P(A,"^"))=""
- S S1=0 F S S1=$O(^PS(53.2,S1)) Q:'S1 D
- . S S2=0 F S S2=$O(^PS(53.2,S1,2,S2)) Q:'S2 D
- .. S A=$G(^PS(53.2,S1,2,S2,0)),PSJSCHD=$P(A,"^",5) Q:PSJSCHD=""
- .. I '$D(^PS(51.1,"AC","PSJ",PSJSCHD)) D MISC(PSJSCHD) I 'OK S ^XTMP("PSJSC","OS","NSS",$P(^PS(53.2,S1,0),"^"))=""
- .. I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","OS","DAN",$P(^PS(53.2,S1,0),"^"))=""
- S S1=0 F S S1=$O(^PS(50.7,S1)) Q:'S1 D
- . S A=^PS(50.7,S1,0),PSJSCHD=$P(A,"^",8),PSJDOF=$$GET1^DIQ(50.606,$P(A,"^",2),.01) Q:PSJSCHD=""
- . I '$D(^PS(51.1,"AC","PSJ",PSJSCHD)) D MISC(PSJSCHD) I 'OK S ^XTMP("PSJSC","OI","NSS",$P(A,"^"))=PSJDOF
- . I $$DANGER(PSJSCHD) S ^XTMP("PSJSC","OI","DAN",$P(A,"^"))=PSJDOF
- S:$D(^XTMP("PSJSC")) ^XTMP("PSJSC",0)=EXPR_"^"_CREAT
- D SENDMSG^PSJA0103
- DONE ;
- K PSG,X,XMDUZ,XMSUB,XMTEXT,XMY,Y,ZTDESC,ZTDTH,ZTIO,ZTREQ,ZTRTN,ZTSAVE,ZTSK S ZTREQ="@"
- Q
- DANGER(A) ;
- N B,C,BAD
- S B=$TR(A,".",""),BAD=0
- F I=1:1:$L(B," ") S C=$P(B," ",I) I C="QD"!(C="QOD")!(C="HS")!(C="TIW")!(C="QHS") S BAD=1 Q
- Q BAD
- MISC(X) ;
- N A,I,C
- S OK=1 I X["PRN" D Q
- . S C=$L(X," ") F I=1:1:C S A=$P(X," ",I) S:A="PRN" X=$P(X," ",1,I-1) I I<C S X=X_" "_$P(X," ",I+2,99)
- . I X="" S OK=0 Q
- . I '$D(^PS(51.1,"AC","PSJ",X)) S OK=0
- I X?2.4N1"-".E!(X?2.4N) D ENCHK I '$D(X) S OK=0 Q
- D DW I '$D(X) S OK=0
- Q
- ENCHK ;
- I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q
- S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q
- S X(1)=$L(X(1)) I X'["-",X>$E(2400,1,X(1)) K X Q
- F X(2)=2:1:$L(X,"-") S X(3)=$P(X,"-",X(2)) I $S($L(X(3))'=X(1):1,X(3)>$E(2400,1,X(1)):1,1:X(3)'>$P(X,"-",X(2)-1)) K X Q
- K:$D(X) X(1),X(2),X(3) Q
- ;
- DW ;
- S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2)
- I X]"" D ENCHK Q:'$D(X)
- S X=$P(SDW,"@"),X(1)="-" I X?.E1P.E,X'["-" F QX=1:1:$L(X) I $E(X,QX)?1P S X(1)=$E(X,QX) Q
- F Q=1:1:$L(X,X(1)) K:SWD="" X Q:SWD="" S Z=$P(X,X(1),Q) D DWC Q:'$D(X)
- K X(1) S:$D(X) X=SDW Q
- DWC I $L(Z)<2 K X Q
- F QX=1:1:$L(SWD,"^") S Y=$P(SWD,"^",QX) I $P(Y,Z)="" S SWD=$P(SWD,Y,2) S:$L(SWD) SWD=$E(SWD,2,50) Q
- E K X
- Q
- PSJ0103 ;BIR/JLC - Check for Non-Standard Schedules ;01-MAR-04
- +1 ;;5.0; INPATIENT MEDICATIONS ;**103**;16 DEC 97
- +2 ;
- +3 ;Reference to ^PS(50.606 is supported by DBIA# 2174.
- +4 ;Reference to ^PS(50.7 is supported by DBIA# 2180.
- +5 ;Reference to ^PS(51.1 is supported by DBIA# 2177.
- +6 ;Reference to ^PS(52.6 is supported by DBIA# 1231.
- +7 ;Reference to ^PS(55 is supported by DBIA# 2191.
- +8 ;
- ENNV ;
- +1 IF $GET(DUZ)=""
- WRITE !,"Your DUZ is not defined."
- QUIT
- +2 WRITE !,"NUMBER OF DAYS: 365// "
- READ X:DTIME
- IF X="^"!'$TEST
- QUIT
- +3 IF X=""
- SET X=365
- +4 IF X'?1.3N!(X<0)!(X?1.2"?")
- IF X'?1.2"?"
- WRITE $CHAR(7)
- WRITE "Must be number, 1-999 days."
- GOTO ENNV
- +5 SET PSJDAYS=X
- KILL ZTSAVE,ZTSK
- SET ZTSAVE("PSJDAYS")=""
- SET ZTRTN="ENQN^PSJ0103"
- SET ZTDESC="Schedule Search"
- SET ZTIO=""
- DO ^%ZTLOAD
- +6 WRITE !!,"The check of Pharmacy orders is",$SELECT($DATA(ZTSK):"",1:" NOT")," queued",!
- +7 IF $DATA(ZTSK)
- WRITE " (to start NOW).",!!,"YOU WILL RECEIVE A MAILMAN MESSAGE WHEN TASK #"_ZTSK_" HAS COMPLETED."
- +8 QUIT
- ENQN ;
- +1 NEW PSJBEG,PSJPDFN,PSJORD,PSJSCHD,CREAT,EXPR,OCNT,PSJND0,PSJND2,X,A,S1,S2,OK
- +2 DO NOW^%DTC
- SET CREAT=$EXTRACT(%,1,7)
- SET EXPR=$$FMADD^XLFDT(CREAT,30,0,0,0)
- KILL ^XTMP("PSJSC")
- SET PSJSCHD=0
- +3 FOR
- SET PSJSCHD=$ORDER(^PS(51.1,"AC","PSJ",PSJSCHD))
- IF PSJSCHD=""
- QUIT
- IF $$DANGER(PSJSCHD)
- SET ^XTMP("PSJSC","DAN51.1",PSJSCHD)=""
- +4 SET %H=$HOROLOG-PSJDAYS
- DO YMD^%DTC
- SET PSJBEG=X
- FOR
- SET PSJBEG=$ORDER(^PS(55,"AUDS",PSJBEG))
- IF PSJBEG=""
- QUIT
- SET PSJPDFN=0
- FOR
- SET PSJPDFN=$ORDER(^PS(55,"AUDS",PSJBEG,PSJPDFN))
- IF 'PSJPDFN
- QUIT
- Begin DoDot:1
- +5 SET PSJORD=0
- FOR
- SET PSJORD=$ORDER(^PS(55,"AUDS",PSJBEG,PSJPDFN,PSJORD))
- IF 'PSJORD
- QUIT
- Begin DoDot:2
- +6 SET PSJND2=$GET(^PS(55,PSJPDFN,5,PSJORD,2))
- SET PSJND0=^(0)
- SET PSJSCHD=$PIECE(PSJND2,"^")
- Begin DoDot:3
- +7 SET ^XTMP("PSJSC","ALL",PSJSCHD)=""
- +8 IF $$DANGER(PSJSCHD)
- SET ^XTMP("PSJSC","DAN",PSJSCHD)=""
- IF $PIECE(PSJND0,"^",9)="A"
- SET ^XTMP("PSJSC","DANON",PSJSCHD,PSJPDFN,"UD",PSJORD)=$PIECE(PSJND0,"^",2)_"^"_$PIECE(^PS(55,PSJPDFN,5,PSJORD,.2),"^",1,2)
- +9 IF $DATA(^PS(51.1,"AC","PSJ",PSJSCHD))
- QUIT
- +10 DO MISC(PSJSCHD)
- IF OK
- QUIT
- +11 SET ^XTMP("PSJSC","NSS",PSJSCHD)=""
- IF $PIECE(PSJND0,"^",9)="A"
- SET ^XTMP("PSJSC","NSSON",PSJSCHD,PSJPDFN,"UD",PSJORD)=$PIECE(PSJND0,"^",2)_"^"_$PIECE(^PS(55,PSJPDFN,5,PSJORD,.2),"^",1,2)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +12 SET %H=$HOROLOG-PSJDAYS
- DO YMD^%DTC
- SET PSJBEG=X
- FOR
- SET PSJBEG=$ORDER(^PS(55,"AIVS",PSJBEG))
- IF PSJBEG=""
- QUIT
- SET PSJPDFN=0
- FOR
- SET PSJPDFN=$ORDER(^PS(55,"AIVS",PSJBEG,PSJPDFN))
- IF 'PSJPDFN
- QUIT
- Begin DoDot:1
- +13 SET PSJORD=0
- FOR
- SET PSJORD=$ORDER(^PS(55,"AIVS",PSJBEG,PSJPDFN,PSJORD))
- IF 'PSJORD
- QUIT
- Begin DoDot:2
- +14 SET PSJND0=$GET(^PS(55,PSJPDFN,"IV",PSJORD,0))
- SET PSJSCHD=$PIECE(PSJND0,"^",9)
- IF PSJSCHD]""
- Begin DoDot:3
- +15 SET ^XTMP("PSJSC","ALL",PSJSCHD)=""
- +16 SET ITEM=""
- SET A=$ORDER(^PS(55,PSJPDFN,"IV",PSJORD,"AD",0))
- IF A
- SET ITEM="A^"_$PIECE(^(A,0),"^")_"^"_$PIECE(^(0),"^",2)
- +17 IF ITEM=""
- SET A=$ORDER(^PS(55,PSJPDFN,"IV",PSJORD,"SOL",0))
- IF A
- SET ITEM="S^"_$PIECE(^(A,0),"^")_"^"_$PIECE(^(0),"^",2)
- +18 IF $$DANGER(PSJSCHD)
- SET ^XTMP("PSJSC","DAN",PSJSCHD)=""
- IF $PIECE(PSJND0,"^",17)="A"
- SET ^XTMP("PSJSC","DANON",PSJSCHD,PSJPDFN,"IV",PSJORD)=$PIECE(PSJND0,"^",6)_"^"_ITEM
- +19 IF $DATA(^PS(51.1,"AC","PSJ",PSJSCHD))
- QUIT
- +20 DO MISC(PSJSCHD)
- IF OK
- QUIT
- +21 SET ^XTMP("PSJSC","NSS",PSJSCHD)=""
- IF $PIECE(PSJND0,"^",17)="A"
- SET ^XTMP("PSJSC","NSSON",PSJSCHD,PSJPDFN,"IV",PSJORD)=$PIECE(PSJND0,"^",6)_"^"_ITEM
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +22 SET S1=0
- FOR
- SET S1=$ORDER(^PS(52.6,S1))
- IF 'S1
- QUIT
- Begin DoDot:1
- +23 SET A=$GET(^PS(52.6,S1,0))
- SET PSJSCHD=$PIECE(A,"^",5)
- IF PSJSCHD=""
- QUIT
- +24 IF '$DATA(^PS(51.1,"AC","PSJ",PSJSCHD))
- DO MISC(PSJSCHD)
- IF 'OK
- SET ^XTMP("PSJSC","QC","NSS",$PIECE(A,"^"))=""
- +25 IF $$DANGER(PSJSCHD)
- SET ^XTMP("PSJSC","QC","DAN",$PIECE(A,"^"))=""
- +26 SET S2=0
- FOR
- SET S2=$ORDER(^PS(52.6,S1,1,S2))
- IF 'S2
- QUIT
- Begin DoDot:2
- +27 SET A=$GET(^PS(52.6,S1,1,S2,0))
- SET PSJSCHD=$PIECE(A,"^",5)
- IF PSJSCHD=""
- QUIT
- +28 IF '$DATA(^PS(51.1,"AC","PSJ",PSJSCHD))
- DO MISC(PSJSCHD)
- IF 'OK
- SET ^XTMP("PSJSC","QC","NSS",$PIECE(A,"^"))=""
- +29 IF $$DANGER(PSJSCHD)
- SET ^XTMP("PSJSC","QC","DAN",$PIECE(A,"^"))=""
- End DoDot:2
- End DoDot:1
- +30 SET S1=0
- FOR
- SET S1=$ORDER(^PS(53.2,S1))
- IF 'S1
- QUIT
- Begin DoDot:1
- +31 SET S2=0
- FOR
- SET S2=$ORDER(^PS(53.2,S1,2,S2))
- IF 'S2
- QUIT
- Begin DoDot:2
- +32 SET A=$GET(^PS(53.2,S1,2,S2,0))
- SET PSJSCHD=$PIECE(A,"^",5)
- IF PSJSCHD=""
- QUIT
- +33 IF '$DATA(^PS(51.1,"AC","PSJ",PSJSCHD))
- DO MISC(PSJSCHD)
- IF 'OK
- SET ^XTMP("PSJSC","OS","NSS",$PIECE(^PS(53.2,S1,0),"^"))=""
- +34 IF $$DANGER(PSJSCHD)
- SET ^XTMP("PSJSC","OS","DAN",$PIECE(^PS(53.2,S1,0),"^"))=""
- End DoDot:2
- End DoDot:1
- +35 SET S1=0
- FOR
- SET S1=$ORDER(^PS(50.7,S1))
- IF 'S1
- QUIT
- Begin DoDot:1
- +36 SET A=^PS(50.7,S1,0)
- SET PSJSCHD=$PIECE(A,"^",8)
- SET PSJDOF=$$GET1^DIQ(50.606,$PIECE(A,"^",2),.01)
- IF PSJSCHD=""
- QUIT
- +37 IF '$DATA(^PS(51.1,"AC","PSJ",PSJSCHD))
- DO MISC(PSJSCHD)
- IF 'OK
- SET ^XTMP("PSJSC","OI","NSS",$PIECE(A,"^"))=PSJDOF
- +38 IF $$DANGER(PSJSCHD)
- SET ^XTMP("PSJSC","OI","DAN",$PIECE(A,"^"))=PSJDOF
- End DoDot:1
- +39 IF $DATA(^XTMP("PSJSC"))
- SET ^XTMP("PSJSC",0)=EXPR_"^"_CREAT
- +40 DO SENDMSG^PSJA0103
- DONE ;
- +1 KILL PSG,X,XMDUZ,XMSUB,XMTEXT,XMY,Y,ZTDESC,ZTDTH,ZTIO,ZTREQ,ZTRTN,ZTSAVE,ZTSK
- SET ZTREQ="@"
- +2 QUIT
- DANGER(A) ;
- +1 NEW B,C,BAD
- +2 SET B=$TRANSLATE(A,".","")
- SET BAD=0
- +3 FOR I=1:1:$LENGTH(B," ")
- SET C=$PIECE(B," ",I)
- IF C="QD"!(C="QOD")!(C="HS")!(C="TIW")!(C="QHS")
- SET BAD=1
- QUIT
- +4 QUIT BAD
- MISC(X) ;
- +1 NEW A,I,C
- +2 SET OK=1
- IF X["PRN"
- Begin DoDot:1
- +3 SET C=$LENGTH(X," ")
- FOR I=1:1:C
- SET A=$PIECE(X," ",I)
- IF A="PRN"
- SET X=$PIECE(X," ",1,I-1)
- IF I<C
- SET X=X_" "_$PIECE(X," ",I+2,99)
- +4 IF X=""
- SET OK=0
- QUIT
- +5 IF '$DATA(^PS(51.1,"AC","PSJ",X))
- SET OK=0
- End DoDot:1
- QUIT
- +6 IF X?2.4N1"-".E!(X?2.4N)
- DO ENCHK
- IF '$DATA(X)
- SET OK=0
- QUIT
- +7 DO DW
- IF '$DATA(X)
- SET OK=0
- +8 QUIT
- ENCHK ;
- +1 IF $SELECT($LENGTH($PIECE(X,"-"))>4:1,$LENGTH(X)>119:1,$LENGTH(X)<2:1,X'>0:1,1:X'?.ANP)
- KILL X
- QUIT
- +2 SET X(1)=$PIECE(X,"-")
- IF X(1)'?2N
- IF X(1)'?4N
- KILL X
- QUIT
- +3 SET X(1)=$LENGTH(X(1))
- IF X'["-"
- IF X>$EXTRACT(2400,1,X(1))
- KILL X
- QUIT
- +4 FOR X(2)=2:1:$LENGTH(X,"-")
- SET X(3)=$PIECE(X,"-",X(2))
- IF $SELECT($LENGTH(X(3))'=X(1):1,X(3)>$EXTRACT(2400,1,X(1)):1,1:X(3)'>$PIECE(X,"-",X(2)-1))
- KILL X
- QUIT
- +5 IF $DATA(X)
- KILL X(1),X(2),X(3)
- QUIT
- +6 ;
- DW ;
- +1 SET SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS"
- SET SDW=X
- SET X=$PIECE(X,"@",2)
- +2 IF X]""
- DO ENCHK
- IF '$DATA(X)
- QUIT
- +3 SET X=$PIECE(SDW,"@")
- SET X(1)="-"
- IF X?.E1P.E
- IF X'["-"
- FOR QX=1:1:$LENGTH(X)
- IF $EXTRACT(X,QX)?1P
- SET X(1)=$EXTRACT(X,QX)
- QUIT
- +4 FOR Q=1:1:$LENGTH(X,X(1))
- IF SWD=""
- KILL X
- IF SWD=""
- QUIT
- SET Z=$PIECE(X,X(1),Q)
- DO DWC
- IF '$DATA(X)
- QUIT
- +5 KILL X(1)
- IF $DATA(X)
- SET X=SDW
- QUIT
- DWC IF $LENGTH(Z)<2
- KILL X
- QUIT
- +1 FOR QX=1:1:$LENGTH(SWD,"^")
- SET Y=$PIECE(SWD,"^",QX)
- IF $PIECE(Y,Z)=""
- SET SWD=$PIECE(SWD,Y,2)
- IF $LENGTH(SWD)
- SET SWD=$EXTRACT(SWD,2,50)
- QUIT
- +2 IF '$TEST
- KILL X
- +3 QUIT
