- RMPRFPRT ;VMP/RB - FIX FIELD LENGTH PROBLEMS FOR FILES #660/664 ;01/13/06
- ;;3.0;Prosthetics;**124**;06/20/05;Build 17
- ;;
- ;1. Post install to correct fields with length error created during
- ; cut & paste for function key input during GUI process and passed
- ; to VISTA files 660 and 664 for fields: Brief Description, Remarks,
- ; Serial #, Manufacturer, Model and Lot #
- ;
- PRINT ;print compile field length errors for specified fields in files 664/660
- N %ZIS
- I $G(^XTMP("RMPRFIX","END COMPILE"))="RUNNING" D Q
- .W !!,"Build is running, please wait until complete!"
- .D WAIT
- I +$G(^XTMP("RMPRFIX","RMPR","COUNT"))=0 D Q
- .W !!,"No field length errors found!"
- .D WAIT
- S %ZIS="Q" D ^%ZIS Q:POP I '$D(IO("Q")) U IO D PRINT1 Q
- S ZTRTN="PRINT1^RMPRFPRT",ZTDESC="RMPR LNGTH ERR RPT" D ^%ZTLOAD,HOME^%ZIS
- Q
- PRINT1 ;
- N RMEND,PG,ORG,HIEN,DATA,XD,FLD,IEN,ERR,ITEM,OBN,IOSL
- S (ORG,RMEND,IEN,HIEN,PG)=0,U="^",IOSL=66 S:$E(IOST,1,2)="C-" IOSL=22
- F S ORG=$O(^XTMP("RMPRFIX","RMPR",ORG)),IEN=0 Q:ORG=""!(ORG]"@")!RMEND D
- .S PG=0,ORGN=$P(^VA(200,ORG,0),U)
- .F S IEN=$O(^XTMP("RMPRFIX","RMPR",ORG,IEN)),ITEM="" Q:IEN=""!RMEND D
- ..F S ITEM=$O(^XTMP("RMPRFIX","RMPR",ORG,IEN,ITEM)),FLD=0 Q:ITEM=""!RMEND D
- ...F S FLD=$O(^XTMP("RMPRFIX","RMPR",ORG,IEN,ITEM,FLD)) Q:FLD=""!RMEND D
- ....S ERR=^XTMP("RMPRFIX","RMPR",ORG,IEN,ITEM,FLD)
- ....I IEN'=HIEN D HDR Q:RMEND S HIEN=IEN
- ....I $Y+4>IOSL D HDR Q:RMEND
- ....W !!,"Field: ",$P(ERR,U,3),?35,"Origin: ",$E($P(ERR,U,7),1,35),!,?10,"MIN: ",$P(ERR,U),?20,"MAX: ",$P(ERR,U,2),?35,"ERR LGTH: ",$P(ERR,U,5)
- ....W ?70,ITEM,"/",$P(ERR,U,10),!
- ....S DATA=$P(ERR,U,12)
- ....F I=1:70 S XD=$E(DATA,I,I+69) Q:XD="" D Q:RMEND
- .....I $Y+2>IOSL D HDR Q:RMEND
- .....W ! W:I=1 "DATA: " W ?8,XD
- W @IOF
- D ^%ZISC
- Q
- HDR ;
- I PG,$E(IOST,1,2)="C-" S RMEND=$$EOP^ESPUTIL() Q:RMEND W @IOF
- E W @IOF
- S PG=PG+1
- W !!,?23,"File 664/660 Field Length Errors",?70,"Page ",PG,!
- W !,"Originator=>> ",ORGN,!
- W !,?2,"IEN",?20,"Patient Name",?50,"IFCAP ORDER",!
- W !,?2,IEN,?20,$P(ERR,U,4),?50,$P(ERR,U,6),!
- Q
- WAIT ;
- ;Q:IO'=$G(IO("HOME"))
- N DIR,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
- W ! S DIR(0)="E" S DIR("A")="Enter RETURN to continue" D ^DIR W !
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRFPRT 2242 printed Feb 19, 2025@00:01:16 Page 2
- RMPRFPRT ;VMP/RB - FIX FIELD LENGTH PROBLEMS FOR FILES #660/664 ;01/13/06
- +1 ;;3.0;Prosthetics;**124**;06/20/05;Build 17
- +2 ;;
- +3 ;1. Post install to correct fields with length error created during
- +4 ; cut & paste for function key input during GUI process and passed
- +5 ; to VISTA files 660 and 664 for fields: Brief Description, Remarks,
- +6 ; Serial #, Manufacturer, Model and Lot #
- +7 ;
- PRINT ;print compile field length errors for specified fields in files 664/660
- +1 NEW %ZIS
- +2 IF $GET(^XTMP("RMPRFIX","END COMPILE"))="RUNNING"
- Begin DoDot:1
- +3 WRITE !!,"Build is running, please wait until complete!"
- +4 DO WAIT
- End DoDot:1
- QUIT
- +5 IF +$GET(^XTMP("RMPRFIX","RMPR","COUNT"))=0
- Begin DoDot:1
- +6 WRITE !!,"No field length errors found!"
- +7 DO WAIT
- End DoDot:1
- QUIT
- +8 SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- IF '$DATA(IO("Q"))
- USE IO
- DO PRINT1
- QUIT
- +9 SET ZTRTN="PRINT1^RMPRFPRT"
- SET ZTDESC="RMPR LNGTH ERR RPT"
- DO ^%ZTLOAD
- DO HOME^%ZIS
- +10 QUIT
- PRINT1 ;
- +1 NEW RMEND,PG,ORG,HIEN,DATA,XD,FLD,IEN,ERR,ITEM,OBN,IOSL
- +2 SET (ORG,RMEND,IEN,HIEN,PG)=0
- SET U="^"
- SET IOSL=66
- if $EXTRACT(IOST,1,2)="C-"
- SET IOSL=22
- +3 FOR
- SET ORG=$ORDER(^XTMP("RMPRFIX","RMPR",ORG))
- SET IEN=0
- if ORG=""!(ORG]"@")!RMEND
- QUIT
- Begin DoDot:1
- +4 SET PG=0
- SET ORGN=$PIECE(^VA(200,ORG,0),U)
- +5 FOR
- SET IEN=$ORDER(^XTMP("RMPRFIX","RMPR",ORG,IEN))
- SET ITEM=""
- if IEN=""!RMEND
- QUIT
- Begin DoDot:2
- +6 FOR
- SET ITEM=$ORDER(^XTMP("RMPRFIX","RMPR",ORG,IEN,ITEM))
- SET FLD=0
- if ITEM=""!RMEND
- QUIT
- Begin DoDot:3
- +7 FOR
- SET FLD=$ORDER(^XTMP("RMPRFIX","RMPR",ORG,IEN,ITEM,FLD))
- if FLD=""!RMEND
- QUIT
- Begin DoDot:4
- +8 SET ERR=^XTMP("RMPRFIX","RMPR",ORG,IEN,ITEM,FLD)
- +9 IF IEN'=HIEN
- DO HDR
- if RMEND
- QUIT
- SET HIEN=IEN
- +10 IF $Y+4>IOSL
- DO HDR
- if RMEND
- QUIT
- +11 WRITE !!,"Field: ",$PIECE(ERR,U,3),?35,"Origin: ",$EXTRACT($PIECE(ERR,U,7),1,35),!,?10,"MIN: ",$PIECE(ERR,U),?20,"MAX: ",$PIECE(ERR,U,2),?35,"ERR LGTH: ",$PIECE(ERR,U,5)
- +12 WRITE ?70,ITEM,"/",$PIECE(ERR,U,10),!
- +13 SET DATA=$PIECE(ERR,U,12)
- +14 FOR I=1:70
- SET XD=$EXTRACT(DATA,I,I+69)
- if XD=""
- QUIT
- Begin DoDot:5
- +15 IF $Y+2>IOSL
- DO HDR
- if RMEND
- QUIT
- +16 WRITE !
- if I=1
- WRITE "DATA: "
- WRITE ?8,XD
- End DoDot:5
- if RMEND
- QUIT
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +17 WRITE @IOF
- +18 DO ^%ZISC
- +19 QUIT
- HDR ;
- +1 IF PG
- IF $EXTRACT(IOST,1,2)="C-"
- SET RMEND=$$EOP^ESPUTIL()
- if RMEND
- QUIT
- WRITE @IOF
- +2 IF '$TEST
- WRITE @IOF
- +3 SET PG=PG+1
- +4 WRITE !!,?23,"File 664/660 Field Length Errors",?70,"Page ",PG,!
- +5 WRITE !,"Originator=>> ",ORGN,!
- +6 WRITE !,?2,"IEN",?20,"Patient Name",?50,"IFCAP ORDER",!
- +7 WRITE !,?2,IEN,?20,$PIECE(ERR,U,4),?50,$PIECE(ERR,U,6),!
- +8 QUIT
- WAIT ;
- +1 ;Q:IO'=$G(IO("HOME"))
- +2 NEW DIR,X,Y,DIRUT,DUOUT,DTOUT,DIROUT
- +3 WRITE !
- SET DIR(0)="E"
- SET DIR("A")="Enter RETURN to continue"
- DO ^DIR
- WRITE !
- +4 QUIT