- ENBCPM3 ;(WASH ISC)/DH-Bar Coded PMI ;3.4.97
- ;;7.0;ENGINEERING;**21,35**;Aug 17, 1993
- NOLBL ;No bar code label scanned
- N ENDA,EN,ENSN,ENMOD
- F I=0,1,2 S EN(I)=""
- S ENLBL="NO LABEL",EN(0)=$E(ENEQ,5,40),ENX1=$O(^PRCT(446.4,ENCTID,2,ENCTTI,1,ENX)) I ENX1]"" S EN(1)=$S($E(^(ENX1,0))="*":"",1:^(0)) S:$E(EN(1),1,4)="S/N:" ^(0)="*"_EN(1),ENX=ENX1,EN(1)=$E(EN(1),5,40)
- S EN(2)="NO DESCRIPTION.",ENX1=$O(^PRCT(446.4,ENCTID,2,ENCTTI,1,ENX)) S ENLKAHD=$S(ENX1]"":^(ENX1,0),1:"")
- I ENLKAHD]"",$E(ENLKAHD)'="*",$E(ENLKAHD,1,2)'="SP",$E(ENLKAHD,1,4)'="MOD:",$E(ENLKAHD,1,4)'="PM#:",ENLKAHD'[" EE" S EN(2)=ENLKAHD,ENX=ENX1,^PRCT(446.4,ENCTID,2,ENCTTI,1,ENX,0)="*"_ENLKAHD
- I EN(0)[" " D
- . F Q:$E(EN(0))'=" " S EN(0)=$E(EN(0),2,99)
- . F Q:$E(EN(0),$L(EN(0)))'=" " S EN(0)=$E(EN(0),1,($L(EN(0))-1))
- I EN(1)[" " D
- . F Q:$E(EN(0))'=" " S EN(0)=$E(EN(0),2,99)
- . F Q:$E(EN(0),$L(EN(0)))'=" " S EN(0)=$E(EN(0),1,($L(EN(0))-1))
- I EN(1)]"" D
- . S ENDA=$O(^ENG(6914,"F",EN(1),0)) I ENDA>0 S ENSN=EN(1) Q
- . S EN(1,0)=$TR(EN(1)," ~!@#$%^&*()_+|`-=\[]{};':"",./<>?",""),EN(1,0)=$$UP^XLFSTR(EN(1,0)) S ENDA=$O(^ENG(6914,"FC",(EN(1,0)_" "),0)) I ENDA>0 S ENSN=$P($G(^ENG(6914,ENDA,1)),U,3)
- I $G(ENSN)]"" D Q
- . I EN(0)'=$P($G(^ENG(6914,ENDA,1)),U,2) S ENMSG(0,2)="NOTE: Entered MODEL ("_EN(0)_") does not match stored value."
- . S ENEQ=ENDA D MATCH,POST^ENBCPM4
- ;If match found EN will be killed
- I $D(EN) S ENMSG="ITEM NOT IN DATABASE.",ENMSG(0,1)="Model: "_EN(0),ENMSG(0,2)="Serial number: "_EN(1),ENMSG(0,3)="Description: "_EN(2) D TKNOTE,XCPTN^ENBCPM2
- Q
- ;
- PMN ;Process PM #
- S ENLBL="NO LABEL",^PRCT(446.4,ENCTID,2,ENCTTI,1,ENX,0)="*"_ENEQ,ENEQ=$E(ENEQ,5,40) S:ENEQ[" " ENEQ=$TR(ENEQ," ") S ENDA=$O(^ENG(6914,"C",ENEQ,0)) I ENDA>0 S ENEQ=ENDA D MATCH,POST^ENBCPM4 Q
- S ENMSG="ITEM NOT IN DATABASE.",ENMSG(0,1)="PM #: "_ENEQ
- D TKNOTE,XCPTN^ENBCPM2
- Q
- ;
- MATCH ; Equipment unlabelled but present in 6914
- S ENMSG="BAR CODE LABEL MISSING. Equipment ID#: "_ENEQ,ENMSG(0,1)="Record will be updated, but bar code label should be printed and applied."
- D XCPTN^ENBCPM2
- D UPDATE^ENBCPM2
- K EN Q
- ;
- TKNOTE ;Addtn'l info to Excptn Mess
- S ENX1=$O(^PRCT(446.4,ENCTID,2,ENCTTI,1,ENX)) S ENLKAHD=$S(ENX1]"":^(ENX1,0),1:"") G:ENLKAHD="" TKNOTE2
- I $E(ENLKAHD)'="*",$E(ENLKAHD,1,2)'="SP",$E(ENLKAHD,1,4)'="MOD:",$E(ENLKAHD,1,4)'="PM#:",ENLKAHD'[" EE" D TKNOTE1 S ENX=ENX1,^PRCT(446.4,ENCTID,2,ENCTTI,1,ENX,0)="*"_ENLKAHD G TKNOTE
- G TKNOTE2
- ;
- TKNOTE1 F J=0:0 S J=$O(ENMSG(0,J)) Q:J'>0 S I=J
- S I=I+1,ENMSG(0,I)=ENLKAHD
- Q
- ;
- TKNOTE2 ;Exit subrtn
- Q
- ;
- HOLD I $E(IOST,1,2)="C-" W !,"Press RETURN to continue..." R X:DTIME
- Q
- ;ENBCPM3
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENBCPM3 2675 printed Mar 13, 2025@20:56:42 Page 2
- ENBCPM3 ;(WASH ISC)/DH-Bar Coded PMI ;3.4.97
- +1 ;;7.0;ENGINEERING;**21,35**;Aug 17, 1993
- NOLBL ;No bar code label scanned
- +1 NEW ENDA,EN,ENSN,ENMOD
- +2 FOR I=0,1,2
- SET EN(I)=""
- +3 SET ENLBL="NO LABEL"
- SET EN(0)=$EXTRACT(ENEQ,5,40)
- SET ENX1=$ORDER(^PRCT(446.4,ENCTID,2,ENCTTI,1,ENX))
- IF ENX1]""
- SET EN(1)=$SELECT($EXTRACT(^(ENX1,0))="*":"",1:^(0))
- if $EXTRACT(EN(1),1,4)="S/N
- SET ^(0)="*"_EN(1)
- SET ENX=ENX1
- SET EN(1)=$EXTRACT(EN(1),5,40)
- +4 SET EN(2)="NO DESCRIPTION."
- SET ENX1=$ORDER(^PRCT(446.4,ENCTID,2,ENCTTI,1,ENX))
- SET ENLKAHD=$SELECT(ENX1]"":^(ENX1,0),1:"")
- +5 IF ENLKAHD]""
- IF $EXTRACT(ENLKAHD)'="*"
- IF $EXTRACT(ENLKAHD,1,2)'="SP"
- IF $EXTRACT(ENLKAHD,1,4)'="MOD:"
- IF $EXTRACT(ENLKAHD,1,4)'="PM#:"
- IF ENLKAHD'[" EE"
- SET EN(2)=ENLKAHD
- SET ENX=ENX1
- SET ^PRCT(446.4,ENCTID,2,ENCTTI,1,ENX,0)="*"_ENLKAHD
- +6 IF EN(0)[" "
- Begin DoDot:1
- +7 FOR
- if $EXTRACT(EN(0))'=" "
- QUIT
- SET EN(0)=$EXTRACT(EN(0),2,99)
- +8 FOR
- if $EXTRACT(EN(0),$LENGTH(EN(0)))'=" "
- QUIT
- SET EN(0)=$EXTRACT(EN(0),1,($LENGTH(EN(0))-1))
- End DoDot:1
- +9 IF EN(1)[" "
- Begin DoDot:1
- +10 FOR
- if $EXTRACT(EN(0))'=" "
- QUIT
- SET EN(0)=$EXTRACT(EN(0),2,99)
- +11 FOR
- if $EXTRACT(EN(0),$LENGTH(EN(0)))'=" "
- QUIT
- SET EN(0)=$EXTRACT(EN(0),1,($LENGTH(EN(0))-1))
- End DoDot:1
- +12 IF EN(1)]""
- Begin DoDot:1
- +13 SET ENDA=$ORDER(^ENG(6914,"F",EN(1),0))
- IF ENDA>0
- SET ENSN=EN(1)
- QUIT
- +14 SET EN(1,0)=$TRANSLATE(EN(1)," ~!@#$%^&*()_+|`-=\[]{};':"",./<>?","")
- SET EN(1,0)=$$UP^XLFSTR(EN(1,0))
- SET ENDA=$ORDER(^ENG(6914,"FC",(EN(1,0)_" "),0))
- IF ENDA>0
- SET ENSN=$PIECE($GET(^ENG(6914,ENDA,1)),U,3)
- End DoDot:1
- +15 IF $GET(ENSN)]""
- Begin DoDot:1
- +16 IF EN(0)'=$PIECE($GET(^ENG(6914,ENDA,1)),U,2)
- SET ENMSG(0,2)="NOTE: Entered MODEL ("_EN(0)_") does not match stored value."
- +17 SET ENEQ=ENDA
- DO MATCH
- DO POST^ENBCPM4
- End DoDot:1
- QUIT
- +18 ;If match found EN will be killed
- +19 IF $DATA(EN)
- SET ENMSG="ITEM NOT IN DATABASE."
- SET ENMSG(0,1)="Model: "_EN(0)
- SET ENMSG(0,2)="Serial number: "_EN(1)
- SET ENMSG(0,3)="Description: "_EN(2)
- DO TKNOTE
- DO XCPTN^ENBCPM2
- +20 QUIT
- +21 ;
- PMN ;Process PM #
- +1 SET ENLBL="NO LABEL"
- SET ^PRCT(446.4,ENCTID,2,ENCTTI,1,ENX,0)="*"_ENEQ
- SET ENEQ=$EXTRACT(ENEQ,5,40)
- if ENEQ[" "
- SET ENEQ=$TRANSLATE(ENEQ," ")
- SET ENDA=$ORDER(^ENG(6914,"C",ENEQ,0))
- IF ENDA>0
- SET ENEQ=ENDA
- DO MATCH
- DO POST^ENBCPM4
- QUIT
- +2 SET ENMSG="ITEM NOT IN DATABASE."
- SET ENMSG(0,1)="PM #: "_ENEQ
- +3 DO TKNOTE
- DO XCPTN^ENBCPM2
- +4 QUIT
- +5 ;
- MATCH ; Equipment unlabelled but present in 6914
- +1 SET ENMSG="BAR CODE LABEL MISSING. Equipment ID#: "_ENEQ
- SET ENMSG(0,1)="Record will be updated, but bar code label should be printed and applied."
- +2 DO XCPTN^ENBCPM2
- +3 DO UPDATE^ENBCPM2
- +4 KILL EN
- QUIT
- +5 ;
- TKNOTE ;Addtn'l info to Excptn Mess
- +1 SET ENX1=$ORDER(^PRCT(446.4,ENCTID,2,ENCTTI,1,ENX))
- SET ENLKAHD=$SELECT(ENX1]"":^(ENX1,0),1:"")
- if ENLKAHD=""
- GOTO TKNOTE2
- +2 IF $EXTRACT(ENLKAHD)'="*"
- IF $EXTRACT(ENLKAHD,1,2)'="SP"
- IF $EXTRACT(ENLKAHD,1,4)'="MOD:"
- IF $EXTRACT(ENLKAHD,1,4)'="PM#:"
- IF ENLKAHD'[" EE"
- DO TKNOTE1
- SET ENX=ENX1
- SET ^PRCT(446.4,ENCTID,2,ENCTTI,1,ENX,0)="*"_ENLKAHD
- GOTO TKNOTE
- +3 GOTO TKNOTE2
- +4 ;
- TKNOTE1 FOR J=0:0
- SET J=$ORDER(ENMSG(0,J))
- if J'>0
- QUIT
- SET I=J
- +1 SET I=I+1
- SET ENMSG(0,I)=ENLKAHD
- +2 QUIT
- +3 ;
- TKNOTE2 ;Exit subrtn
- +1 QUIT
- +2 ;
- HOLD IF $EXTRACT(IOST,1,2)="C-"
- WRITE !,"Press RETURN to continue..."
- READ X:DTIME
- +1 QUIT
- +2 ;ENBCPM3
