- PSGPL0 ;BIR/CML3-GETS UNITS COUNT FOR PSGPL & PSGPEN ;29 OCT 96 / 8:31 PM
- ;;5.0; INPATIENT MEDICATIONS ;**50,83,110,125,129**;16 DEC 97
- ;
- ; Reference to ^PS(51.1 supported by DBIA #2177.
- ; Reference to ^PS(55 is supported by DBIA #2191.
- ;
- EN ;
- K PSGMAR S PSGPLC=0 D RUN
- ;
- DONE K HCD,HM,I,J,PSGD,PLSD,CD,M,MID,MN,ND,ND1,PREX,OD,ST,QD1,QD2,QQ,TS,UD,WDT,WS,WS1,X,X1,X2 Q
- ;
- RUN ; quit if fill on request prn or stop date not found
- S ND1=$P($G(^PS(55,PSGP,5,PSGPLO,0)),"^",7) Q:('$D(PSGMFOR)&(ND1="R")) I $F("OCP",ND1)-1'>0,('$D(PSGMFOR)) S PSGPLC="OI" Q
- S ND=$G(^PS(55,PSGP,5,PSGPLO,2)) Q:($P(ND,"^")["PRN")&('$D(PSJPRN)) Q:$P(ND,"^")="PRN"
- S ST=$P(ND,"^",2) N RNDT S RNDT=$$LASTREN^PSJLMPRI(PSGP,+PSGPLO_"U")
- I RNDT N OSTOP S OSTOP=$P(RNDT,"^",4) I $D(PSGPENO) S ST=$S((((RNDT<OSTOP))!$G(PSJREN)):+OSTOP,1:+RNDT)
- I $G(PSJREN)&$G(PSJRNOS) S:PSJRNOS>$G(PSGDT) ST=PSJRNOS S:$G(PSGFD) $P(ND,"^",4)=PSGFD
- S PLSD=$P(ND,"^",4),TS=$P(ND,"^",5)
- S MN=$P(ND,"^",6),ND=$P(ND,"^") D:ND["PRN" SETMN I $S(ST'?7N1"."1N.E:1,1:PLSD'?7N1"."1N.E) S PSGPLC="OI" Q
- ;Quit if One Time order and dosage was given through "PRE-EXCHANGE".
- S PREX=$G(^PS(55,PSGP,5,PSGPLO,1,1,0)) I $$ONE^PSJBCMA(PSGP,PSGPLO_"U",$P(ND,"^",1))="O",$P(PREX,"^",12)'="",$P(PREX,"^",2)'="",$P(PREX,"^",2)'>$P(PREX,"^",12) Q
- ENIV ;*** Entry to be called from ^PSGMIV (24 HOUR MAR IV).
- Q:ST'<PSGPLF I ND1="O"!(ND1="OC")!(MN="O") S PSGPLC=PLSD'<PSGPLS S:ND1'["C"&PSGPLC PSGMAR($E(+$P(ST,".",2)_"0",1,2))="" Q
- I (TS'>0!("24"'[$L($P(TS,"-")))),MN="",ND'["@" S PSGPLC="OI" Q
- S CD=$S(PSGPLF>PLSD:PLSD,1:PSGPLF),OD=$S(ST>PSGPLS:ST,1:PSGPLS),MID=1 I ND["@"!(MN="D") G MWF
- I MN>1440,TS,'(MN#1440) G TSFMN
- I TS>0,"24"[$L($P(TS,"-")) S:PSGPLS>ST ST=PSGPLS G TS
- ;
- MN ; if only minutes (MN) are found
- I MN'>0 S PSGPLC="OI" Q
- S (OD,X1)=PSGPLS,HM=MN,X2=ST D ^%DTC I X>1 S AM=X-1*1440\HM*HM D ADD S ST=X
- S (CML,X)=ST F I=0:1 S AM=HM*I,ST=CML D:AM ADD Q:X>CD!(CD=PLSD&(X'<CD)) I X'<OD S PSGPLC=PSGPLC+1,PSGMAR($E($P(X,".",2)_"0",1,2))=""
- S ST=CML Q
- ;
- TSFMN ;if admin times exist and minutes#1440=0
- S X=$P(ST,"."),MID=MN\1440 F I=0:1 S X1=$P(ST,"."),X2=MID*I D:X2 C^%DTC Q:X'<CD I X'<(PSGPLS\1) S ST=$S(PSGPLS\1=X:$S(PSGPLS#1<(ST#1):ST,1:PSGPLS),PSGPLS\1<X:ST,1:PSGPLS) G TS
- Q
- ;
- TS ; admin times
- F Q=1:1 S XX=$P(TS,"-",Q) Q:XX=""!(("."_XX)'<(ST#1))
- TS1 X:XX="" "S X1=ST\1,X2=MID D C^%DTC S ST=X,Q=1" F QQ=Q:1 S XX=$P(TS,"-",QQ) G:XX="" TS1 S ST=$P(ST,".")_"."_XX Q:ST>CD!(CD=PLSD&(ST'<CD)) S:PSGPLS'>ST PSGPLC=PSGPLC+1,PSGMAR($E(XX_"0",1,2))=""
- Q
- ;
- MWF ; schedule in form of WD-WD-WD@TS
- S:ND["@" ND=$P(ND,"@") S:'TS TS=$E($P(ST,".",2)_"0000",1,4) S HCD=CD,X=$P(OD,".")
- S MN="-" I ND'["-",ND?.E1P.E F FQ=1:1:$L(ND) I $E(ND,FQ)?1P S MN=$E(ND,FQ) Q
- F FQ=0:1 S X1=$P(OD,"."),X2=FQ D:X2 C^%DTC Q:X>$P(HCD,".") S CD=$S($P(HCD,".")>X:X_.24,1:HCD),ST=$S($P(OD,".")<X:X_.0001,1:OD) D DW^%DTC S X=X_"S" F FQ1=1:1:$L(ND,MN) I $P(X,$P(ND,MN,FQ1))="" D TS Q
- Q
- ;
- ADD ; ST=start date/time AM=minutes (+ or -) X=new date/time
- S:'AM X=ST Q:'AM S T=1 S:AM<0 T=-1,AM=-AM S X2=AM\1440,AM=AM-(X2*1440),H=AM\60,M=AM#60,HRS=+$E(ST_"00",9,10),MN=+$E(ST_"0000",11,12),X=ST\1
- I M S MN=MN+(M*T) S:MN>59 MN=MN-60,H=H+1 S:MN<0 MN=MN+60,H=H+1
- I H S HRS=HRS+(H*T) S:HRS>24!(HRS=24&MN) HRS=HRS-24,X2=X2+1 S:HRS<0 HRS=HRS+24,X2=X2+1
- I X2 S X1=$P(X,"."),X2=X2*T D C^%DTC
- S X=+(X_"."_$E(0,HRS<10)_HRS_$E(0,MN<10)_MN) K AM,H,HRS,M,MN,T Q
- ;
- SETMN ; Set MN for PRN orders
- Q:($G(MN)]"")!($G(TS)]"")!(ND["Q0") S MNFL=0,MN="",TS="" F XX=0:0 S XX=$O(^PS(51.1,"AC","PSJ",ND,XX)) Q:'XX!(MNFL) D
- .S:$P($G(^PS(51.1,XX,0)),"^",3)'="" MN=$P($G(^(0)),"^",3),MNFL=1 S:$P($G(^(0)),"^",2)'="" TS=$P($G(^(0)),"^",2),MNFL=1 Q
- I 'MNFL,$E(ND,1,3)'="PRN" D
- .S PRND=$P(ND,"PRN") D:$E(PRND,$L(PRND))=" " F XX=0:0 S XX=$O(^PS(51.1,"AC","PSJ",PRND,XX)) Q:'XX!(MNFL) S:$P($G(^PS(51.1,XX,0)),"^",3)'="" MN=$P($G(^(0)),"^",3),MNFL=1 S:$P($G(^(0)),"^",2)'="" TS=$P($G(^(0)),"^",2),MNFL=1
- ..F S PRND=$E(PRND,1,$L(PRND)-1) Q:$E(PRND,$L(PRND))'=" "
- I 'MNFL,$E(ND,1,3)="PRN" S PRND=$P(ND,"PRN",2) D:$E(PRND)=" " F XX=0:0 S XX=$O(^PS(51.1,"AC","PSJ",PRND,XX)) Q:'XX!(MNFL) S:$P($G(^PS(51.1,XX,0)),"^",3)'="" MN=$P($G(^(0)),"^",3),MNFL=1 S:$P($G(^(0)),"^",2)'="" TS=$P($G(^(0)),"^",2),MNFL=1
- .F S PRND=$E(PRND,2,$L(PRND)) Q:$E(PRND)'=" "
- I 'MNFL D
- .I PRND["@" D DW S:$D(PRND) TS=$P(PRND,"@",2) Q
- .I $E(PRND,1,2)="AD" Q
- .I $E(PRND,1,3)="BID"!($E(PRND,1,3)="TID")!($E(PRND,1,3)="QID") S MN=1440/$F("BTQ",$E(PRND)) Q
- .S:$E(PRND)="Q" PRND=$E(PRND,2,99) S:'PRND PRND="1"_PRND S PRND1=+PRND,PRND=$P(PRND,+PRND,2),PRND2=0 S:PRND1<0 PRND1=-PRND1 S:$E(PRND)="X" PRND2=1,PRND=$E(PRND,2,99)
- .S MN=$S((PRND["D"&(PRND'["AD"))!(PRND["AM")!(PRND["PM")!((PRND["HS")&(PRND'["THS")):1440,((PRND["H")&(PRND'["TH")):60,PRND["AC"!(PRND["PC"):480,PRND["W":10080,PRND["M":40320,1:-1) I MN>0 S:PRND["QO" MN=MN*2 S MN=MN*PRND1 Q:MN>0
- QUIT K XX,MNFL,PRND,PRND1,PRND2,QX,SDW,SWD,Z Q
- ;
- DW ;
- S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=PRND,PRND=$P(PRND,"@",2) D ENCHK Q:'$D(PRND) S PRND=$P(SDW,"@"),PRND(1)="-" I PRND?.E1P.E,PRND'["-" F QX=1:1:$L(PRND) I $E(PRND,QX)?1P S PRND(1)=$E(PRND,QX) Q
- F Q=1:1:$L(PRND,PRND(1)) K:SWD="" PRND Q:SWD="" S Z=$P(PRND,PRND(1),Q) D DWC Q:'$D(PRND)
- K PRND(1) S:$D(PRND) PRND=SDW Q
- DWC I $L(Z)<2 K PRND 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 PRND
- Q
- ;
- ENCHK ;
- I $S($L($P(PRND,"-"))>4:1,$L(PRND)>119:1,$L(PRND)<2:1,PRND'>0:1,1:PRND'?.ANP) K PRND Q
- S PRND(1)=$P(PRND,"-") I PRND(1)'?2N,PRND(1)'?4N K PRND Q
- S PRND(1)=$L(PRND(1)) I PRND'["-",PRND>$E(2400,1,PRND(1)) K PRND Q
- F PRND(2)=2:1:$L(PRND,"-") S PRND(3)=$P(PRND,"-",PRND(2)) I $S($L(PRND(3))'=PRND(1):1,PRND(3)>$E(2400,1,PRND(1)):1,1:PRND(3)'>$P(PRND,"-",PRND(2)-1)) K PRND Q
- K:$D(PRND) PRND(1),PRND(2),PRND(3) Q
-
-
- PSGPL0 ;BIR/CML3-GETS UNITS COUNT FOR PSGPL & PSGPEN ;29 OCT 96 / 8:31 PM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**50,83,110,125,129**;16 DEC 97
- +2 ;
- +3 ; Reference to ^PS(51.1 supported by DBIA #2177.
- +4 ; Reference to ^PS(55 is supported by DBIA #2191.
- +5 ;
- EN ;
- +1 KILL PSGMAR
- SET PSGPLC=0
- DO RUN
- +2 ;
- DONE KILL HCD,HM,I,J,PSGD,PLSD,CD,M,MID,MN,ND,ND1,PREX,OD,ST,QD1,QD2,QQ,TS,UD,WDT,WS,WS1,X,X1,X2
- QUIT
- +1 ;
- RUN ; quit if fill on request prn or stop date not found
- +1 SET ND1=$PIECE($GET(^PS(55,PSGP,5,PSGPLO,0)),"^",7)
- IF ('$DATA(PSGMFOR)&(ND1="R"))
- QUIT
- IF $FIND("OCP",ND1)-1'>0
- IF ('$DATA(PSGMFOR))
- SET PSGPLC="OI"
- QUIT
- +2 SET ND=$GET(^PS(55,PSGP,5,PSGPLO,2))
- IF ($PIECE(ND,"^")["PRN")&('$DATA(PSJPRN))
- QUIT
- IF $PIECE(ND,"^")="PRN"
- QUIT
- +3 SET ST=$PIECE(ND,"^",2)
- NEW RNDT
- SET RNDT=$$LASTREN^PSJLMPRI(PSGP,+PSGPLO_"U")
- +4 IF RNDT
- NEW OSTOP
- SET OSTOP=$PIECE(RNDT,"^",4)
- IF $DATA(PSGPENO)
- SET ST=$SELECT((((RNDT<OSTOP))!$GET(PSJREN)):+OSTOP,1:+RNDT)
- +5 IF $GET(PSJREN)&$GET(PSJRNOS)
- IF PSJRNOS>$GET(PSGDT)
- SET ST=PSJRNOS
- IF $GET(PSGFD)
- SET $PIECE(ND,"^",4)=PSGFD
- +6 SET PLSD=$PIECE(ND,"^",4)
- SET TS=$PIECE(ND,"^",5)
- +7 SET MN=$PIECE(ND,"^",6)
- SET ND=$PIECE(ND,"^")
- IF ND["PRN"
- DO SETMN
- IF $SELECT(ST'?7N1"."1N.E:1,1:PLSD'?7N1"."1N.E)
- SET PSGPLC="OI"
- QUIT
- +8 ;Quit if One Time order and dosage was given through "PRE-EXCHANGE".
- +9 SET PREX=$GET(^PS(55,PSGP,5,PSGPLO,1,1,0))
- IF $$ONE^PSJBCMA(PSGP,PSGPLO_"U",$PIECE(ND,"^",1))="O"
- IF $PIECE(PREX,"^",12)'=""
- IF $PIECE(PREX,"^",2)'=""
- IF $PIECE(PREX,"^",2)'>$PIECE(PREX,"^",12)
- QUIT
- ENIV ;*** Entry to be called from ^PSGMIV (24 HOUR MAR IV).
- +1 IF ST'<PSGPLF
- QUIT
- IF ND1="O"!(ND1="OC")!(MN="O")
- SET PSGPLC=PLSD'<PSGPLS
- IF ND1'["C"&PSGPLC
- SET PSGMAR($EXTRACT(+$PIECE(ST,".",2)_"0",1,2))=""
- QUIT
- +2 IF (TS'>0!("24"'[$LENGTH($PIECE(TS,"-"))))
- IF MN=""
- IF ND'["@"
- SET PSGPLC="OI"
- QUIT
- +3 SET CD=$SELECT(PSGPLF>PLSD:PLSD,1:PSGPLF)
- SET OD=$SELECT(ST>PSGPLS:ST,1:PSGPLS)
- SET MID=1
- IF ND["@"!(MN="D")
- GOTO MWF
- +4 IF MN>1440
- IF TS
- IF '(MN#1440)
- GOTO TSFMN
- +5 IF TS>0
- IF "24"[$LENGTH($PIECE(TS,"-"))
- IF PSGPLS>ST
- SET ST=PSGPLS
- GOTO TS
- +6 ;
- MN ; if only minutes (MN) are found
- +1 IF MN'>0
- SET PSGPLC="OI"
- QUIT
- +2 SET (OD,X1)=PSGPLS
- SET HM=MN
- SET X2=ST
- DO ^%DTC
- IF X>1
- SET AM=X-1*1440\HM*HM
- DO ADD
- SET ST=X
- +3 SET (CML,X)=ST
- FOR I=0:1
- SET AM=HM*I
- SET ST=CML
- IF AM
- DO ADD
- IF X>CD!(CD=PLSD&(X'<CD))
- QUIT
- IF X'<OD
- SET PSGPLC=PSGPLC+1
- SET PSGMAR($EXTRACT($PIECE(X,".",2)_"0",1,2))=""
- +4 SET ST=CML
- QUIT
- +5 ;
- TSFMN ;if admin times exist and minutes#1440=0
- +1 SET X=$PIECE(ST,".")
- SET MID=MN\1440
- FOR I=0:1
- SET X1=$PIECE(ST,".")
- SET X2=MID*I
- IF X2
- DO C^%DTC
- IF X'<CD
- QUIT
- IF X'<(PSGPLS\1)
- SET ST=$SELECT(PSGPLS\1=X:$SELECT(PSGPLS#1<(ST#1):ST,1:PSGPLS),PSGPLS\1<X:ST,1:PSGPLS)
- GOTO TS
- +2 QUIT
- +3 ;
- TS ; admin times
- +1 FOR Q=1:1
- SET XX=$PIECE(TS,"-",Q)
- IF XX=""!(("."_XX)'<(ST#1))
- QUIT
- TS1 IF XX=""
- XECUTE "S X1=ST\1,X2=MID D C^%DTC S ST=X,Q=1"
- FOR QQ=Q:1
- SET XX=$PIECE(TS,"-",QQ)
- IF XX=""
- GOTO TS1
- SET ST=$PIECE(ST,".")_"."_XX
- IF ST>CD!(CD=PLSD&(ST'<CD))
- QUIT
- IF PSGPLS'>ST
- SET PSGPLC=PSGPLC+1
- SET PSGMAR($EXTRACT(XX_"0",1,2))=""
- +1 QUIT
- +2 ;
- MWF ; schedule in form of WD-WD-WD@TS
- +1 IF ND["@"
- SET ND=$PIECE(ND,"@")
- IF 'TS
- SET TS=$EXTRACT($PIECE(ST,".",2)_"0000",1,4)
- SET HCD=CD
- SET X=$PIECE(OD,".")
- +2 SET MN="-"
- IF ND'["-"
- IF ND?.E1P.E
- FOR FQ=1:1:$LENGTH(ND)
- IF $EXTRACT(ND,FQ)?1P
- SET MN=$EXTRACT(ND,FQ)
- QUIT
- +3 FOR FQ=0:1
- SET X1=$PIECE(OD,".")
- SET X2=FQ
- IF X2
- DO C^%DTC
- IF X>$PIECE(HCD,".")
- QUIT
- SET CD=$SELECT($PIECE(HCD,".")>X:X_.24,1:HCD)
- SET ST=$SELECT($PIECE(OD,".")<X:X_.0001,1:OD)
- DO DW^%DTC
- SET X=X_"S"
- FOR FQ1=1:1:$LENGTH(ND,MN)
- IF $PIECE(X,$PIECE(ND,MN,FQ1))=""
- DO TS
- QUIT
- +4 QUIT
- +5 ;
- ADD ; ST=start date/time AM=minutes (+ or -) X=new date/time
- +1 IF 'AM
- SET X=ST
- IF 'AM
- QUIT
- SET T=1
- IF AM<0
- SET T=-1
- SET AM=-AM
- SET X2=AM\1440
- SET AM=AM-(X2*1440)
- SET H=AM\60
- SET M=AM#60
- SET HRS=+$EXTRACT(ST_"00",9,10)
- SET MN=+$EXTRACT(ST_"0000",11,12)
- SET X=ST\1
- +2 IF M
- SET MN=MN+(M*T)
- IF MN>59
- SET MN=MN-60
- SET H=H+1
- IF MN<0
- SET MN=MN+60
- SET H=H+1
- +3 IF H
- SET HRS=HRS+(H*T)
- IF HRS>24!(HRS=24&MN)
- SET HRS=HRS-24
- SET X2=X2+1
- IF HRS<0
- SET HRS=HRS+24
- SET X2=X2+1
- +4 IF X2
- SET X1=$PIECE(X,".")
- SET X2=X2*T
- DO C^%DTC
- +5 SET X=+(X_"."_$EXTRACT(0,HRS<10)_HRS_$EXTRACT(0,MN<10)_MN)
- KILL AM,H,HRS,M,MN,T
- QUIT
- +6 ;
- SETMN ; Set MN for PRN orders
- +1 IF ($GET(MN)]"")!($GET(TS)]"")!(ND["Q0")
- QUIT
- SET MNFL=0
- SET MN=""
- SET TS=""
- FOR XX=0:0
- SET XX=$ORDER(^PS(51.1,"AC","PSJ",ND,XX))
- IF 'XX!(MNFL)
- QUIT
- Begin DoDot:1
- +2 IF $PIECE($GET(^PS(51.1,XX,0)),"^",3)'=""
- SET MN=$PIECE($GET(^(0)),"^",3)
- SET MNFL=1
- IF $PIECE($GET(^(0)),"^",2)'=""
- SET TS=$PIECE($GET(^(0)),"^",2)
- SET MNFL=1
- QUIT
- End DoDot:1
- +3 IF 'MNFL
- IF $EXTRACT(ND,1,3)'="PRN"
- Begin DoDot:1
- +4 SET PRND=$PIECE(ND,"PRN")
- IF $EXTRACT(PRND,$LENGTH(PRND))=" "
- Begin DoDot:2
- +5 FOR
- SET PRND=$EXTRACT(PRND,1,$LENGTH(PRND)-1)
- IF $EXTRACT(PRND,$LENGTH(PRND))'=" "
- QUIT
- End DoDot:2
- FOR XX=0:0
- SET XX=$ORDER(^PS(51.1,"AC","PSJ",PRND,XX))
- IF 'XX!(MNFL)
- QUIT
- IF $PIECE($GET(^PS(51.1,XX,0)),"^",3)'=""
- SET MN=$PIECE($GET(^(0)),"^",3)
- SET MNFL=1
- IF $PIECE($GET(^(0)),"^",2)'=""
- SET TS=$PIECE($GET(^(0)),"^",2)
- SET MNFL=1
- End DoDot:1
- +6 IF 'MNFL
- IF $EXTRACT(ND,1,3)="PRN"
- SET PRND=$PIECE(ND,"PRN",2)
- IF $EXTRACT(PRND)=" "
- Begin DoDot:1
- +7 FOR
- SET PRND=$EXTRACT(PRND,2,$LENGTH(PRND))
- IF $EXTRACT(PRND)'=" "
- QUIT
- End DoDot:1
- FOR XX=0:0
- SET XX=$ORDER(^PS(51.1,"AC","PSJ",PRND,XX))
- IF 'XX!(MNFL)
- QUIT
- IF $PIECE($GET(^PS(51.1,XX,0)),"^",3)'=""
- SET MN=$PIECE($GET(^(0)),"^",3)
- SET MNFL=1
- IF $PIECE($GET(^(0)),"^",2)'=""
- SET TS=$PIECE($GET(^(0)),"^",2)
- SET MNFL=1
- +8 IF 'MNFL
- Begin DoDot:1
- +9 IF PRND["@"
- DO DW
- IF $DATA(PRND)
- SET TS=$PIECE(PRND,"@",2)
- QUIT
- +10 IF $EXTRACT(PRND,1,2)="AD"
- QUIT
- +11 IF $EXTRACT(PRND,1,3)="BID"!($EXTRACT(PRND,1,3)="TID")!($EXTRACT(PRND,1,3)="QID")
- SET MN=1440/$FIND("BTQ",$EXTRACT(PRND))
- QUIT
- +12 IF $EXTRACT(PRND)="Q"
- SET PRND=$EXTRACT(PRND,2,99)
- IF 'PRND
- SET PRND="1"_PRND
- SET PRND1=+PRND
- SET PRND=$PIECE(PRND,+PRND,2)
- SET PRND2=0
- IF PRND1<0
- SET PRND1=-PRND1
- IF $EXTRACT(PRND)="X"
- SET PRND2=1
- SET PRND=$EXTRACT(PRND,2,99)
- +13 SET MN=$SELECT((PRND["D"&(PRND'["AD"))!(PRND["AM")!(PRND["PM")!((PRND["HS")&(PRND'["THS")):1440,((PRND["H")&(PRND'["TH")):60,PRND["AC"!(PRND["PC"):480,PRND["W":10080,PRND["M":40320,1:-1)
- IF MN>0
- IF PRND["QO"
- SET MN=MN*2
- SET MN=MN*PRND1
- IF MN>0
- QUIT
- End DoDot:1
- QUIT KILL XX,MNFL,PRND,PRND1,PRND2,QX,SDW,SWD,Z
- QUIT
- +1 ;
- DW ;
- +1 SET SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS"
- SET SDW=PRND
- SET PRND=$PIECE(PRND,"@",2)
- DO ENCHK
- IF '$DATA(PRND)
- QUIT
- SET PRND=$PIECE(SDW,"@")
- SET PRND(1)="-"
- IF PRND?.E1P.E
- IF PRND'["-"
- FOR QX=1:1:$LENGTH(PRND)
- IF $EXTRACT(PRND,QX)?1P
- SET PRND(1)=$EXTRACT(PRND,QX)
- QUIT
- +2 FOR Q=1:1:$LENGTH(PRND,PRND(1))
- IF SWD=""
- KILL PRND
- IF SWD=""
- QUIT
- SET Z=$PIECE(PRND,PRND(1),Q)
- DO DWC
- IF '$DATA(PRND)
- QUIT
- +3 KILL PRND(1)
- IF $DATA(PRND)
- SET PRND=SDW
- QUIT
- DWC IF $LENGTH(Z)<2
- KILL PRND
- 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 PRND
- +3 QUIT
- +4 ;
- ENCHK ;
- +1 IF $SELECT($LENGTH($PIECE(PRND,"-"))>4:1,$LENGTH(PRND)>119:1,$LENGTH(PRND)<2:1,PRND'>0:1,1:PRND'?.ANP)
- KILL PRND
- QUIT
- +2 SET PRND(1)=$PIECE(PRND,"-")
- IF PRND(1)'?2N
- IF PRND(1)'?4N
- KILL PRND
- QUIT
- +3 SET PRND(1)=$LENGTH(PRND(1))
- IF PRND'["-"
- IF PRND>$EXTRACT(2400,1,PRND(1))
- KILL PRND
- QUIT
- +4 FOR PRND(2)=2:1:$LENGTH(PRND,"-")
- SET PRND(3)=$PIECE(PRND,"-",PRND(2))
- IF $SELECT($LENGTH(PRND(3))'=PRND(1):1,PRND(3)>$EXTRACT(2400,1,PRND(1)):1,1:PRND(3)'>$PIECE(PRND,"-",PRND(2)-1))
- KILL PRND
- QUIT
- +5 IF $DATA(PRND)
- KILL PRND(1),PRND(2),PRND(3)
- QUIT
- +6 +7
- ***** ERRORS & WARNINGS IN PSGPL0 *****
- PSGPL0+1 S - 2nd line of routine violates the SAC.
